home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / mac / files / ant_nec / nec_in_c.tz / nec_in_c / NEC2 / nec2.c < prev    next >
C/C++ Source or Header  |  1992-02-29  |  826KB  |  28,350 lines
  1. /* n.f -- translated by f2c (version of 17 January 1992  0:17:58).
  2.    You must link the resulting object file with the libraries:
  3.     -lF77 -lI77 -lm -lc   (in that order)
  4. */
  5.  
  6. #include "f2c.h"
  7.  
  8. /* Common Block Declarations */
  9.  
  10. struct {
  11.     doublecomplex cm[90000];
  12. } cmb_;
  13.  
  14. #define cmb_1 cmb_
  15.  
  16. struct {
  17.     doublereal x[600], y[600], z[600], si[600], bi[600], alp[600], bet[600], 
  18.         wlam;
  19.     integer icon1[800], icon2[800], itag[800], iconx[600], ipsym, ld, n1, n2, 
  20.         n, np, m1, m2, m, mp;
  21. } data_;
  22.  
  23. #define data_1 data_
  24.  
  25. struct {
  26.     integer icase, nbloks, npblk, nlast, nblsym, npsym, nlsym, imat, icasx, 
  27.         nbbx, npbx, nlbx, nbbl, npbl, nlbl;
  28. } matpar_;
  29.  
  30. #define matpar_1 matpar_
  31.  
  32. struct {
  33.     doublereal com[95]    /* was [19][5] */, epsr, sig, scrwlt, scrwrt, fmhz;
  34.     integer ip[800], kcom;
  35. } save_;
  36.  
  37. #define save_1 save_
  38.  
  39. struct {
  40.     doublereal air[600], aii[600], bir[600], bii[600], cir[600], cii[600];
  41.     doublecomplex cur[1000];
  42. } crnt_;
  43.  
  44. #define crnt_1 crnt_
  45.  
  46. struct {
  47.     doublecomplex zrati, zrati2, frati;
  48.     doublereal cl, ch, scrwl, scrwr;
  49.     integer nradl, ksymp, ifar, iperf;
  50.     doublecomplex t1;
  51.     doublereal t2;
  52. } gnd_;
  53.  
  54. #define gnd_1 gnd_
  55.  
  56. struct {
  57.     doublecomplex zarray[600];
  58.     integer nload, nlodf;
  59. } zload_;
  60.  
  61. #define zload_1 zload_
  62.  
  63. struct {
  64.     integer ncoup, icoup, nctag[5], ncseg[5];
  65.     doublecomplex y11a[5], y12a[20];
  66. } yparm_;
  67.  
  68. #define yparm_1 yparm_
  69.  
  70. struct {
  71.     doublereal ax[30], bx[30], cx[30];
  72.     integer jco[30], jsno, iscon[50], nscon, ipcon[10], npcon;
  73. } segj_;
  74.  
  75. #define segj_1 segj_
  76.  
  77. struct {
  78.     doublecomplex vqd[30], vsant[30], vqds[30];
  79.     integer ivqd[30], isant[30], iqds[30], nvqd, nsant, nqds;
  80. } vsorc_;
  81.  
  82. #define vsorc_1 vsorc_
  83.  
  84. struct {
  85.     doublecomplex zped;
  86.     doublereal pin, pnls, x11r[150], x11i[150], x12r[150], x12i[150], x22r[
  87.         150], x22i[150];
  88.     integer ntyp[150], neq, npeq, neq2, nonet, ntsol, nprint, masym, iseg1[
  89.         150], iseg2[150];
  90. } netcx_;
  91.  
  92. #define netcx_1 netcx_
  93.  
  94. struct {
  95.     doublereal thets, phis, dth, dph, rfld, gnor, clt, cht, epsr2, sig2, xpr6,
  96.          pinr, pnlr, ploss, xnr, ynr, znr, dxnr, dynr, dznr;
  97.     integer nth, nph, ipd, iavp, inor, iax, ixtyp, near, nfeh, nrx, nry, nrz;
  98. } fpat_;
  99.  
  100. #define fpat_1 fpat_
  101.  
  102. struct {
  103.     doublecomplex ar1[440]    /* was [11][10][4] */, ar2[340]    /* was [17][5]
  104.         [4] */, ar3[288]    /* was [9][8][4] */, epscf;
  105.     doublereal dxa[3], dya[3], xsa[3], ysa[3];
  106.     integer nxa[3], nya[3];
  107. } ggrid_;
  108.  
  109. #define ggrid_1 ggrid_
  110.  
  111. struct {
  112.     doublecomplex u, u2, xx1, xx2;
  113.     doublereal r1, r2, zmh, zph;
  114. } gwav_;
  115.  
  116. #define gwav_1 gwav_
  117.  
  118. struct {
  119.     integer iplp1, iplp2, iplp3, iplp4;
  120. } plot_;
  121.  
  122. #define plot_1 plot_
  123.  
  124. struct {
  125.     doublereal salp[600];
  126. } angl_;
  127.  
  128. #define angl_1 angl_
  129.  
  130. struct {
  131.     doublereal s, b, xj, yj, zj, cabj, sabj, salpj;
  132.     doublecomplex exk, eyk, ezk, exs, eys, ezs, exc, eyc, ezc;
  133.     doublereal rkh;
  134.     integer iexk, ind1, indd1, ind2, indd2, ipgnd;
  135. } dataj_;
  136.  
  137. #define dataj_1 dataj_
  138.  
  139. struct {
  140.     doublecomplex ssx[256]    /* was [16][16] */;
  141. } smat_;
  142.  
  143. #define smat_1 smat_
  144.  
  145. union {
  146.     struct {
  147.     doublecomplex d[800];
  148.     } _1;
  149.     struct {
  150.     doublecomplex y[800];
  151.     } _2;
  152.     struct {
  153.     doublereal gain[800];
  154.     } _3;
  155. } scratm_;
  156.  
  157. #define scratm_1 (scratm_._1)
  158. #define scratm_2 (scratm_._2)
  159. #define scratm_3 (scratm_._3)
  160.  
  161. struct {
  162.     doublereal xo, yo, zo, sn, xsn, ysn;
  163.     integer isnor;
  164. } incom_;
  165.  
  166. #define incom_1 incom_
  167.  
  168. union {
  169.     struct {
  170.     doublereal zpk, rkb2;
  171.     integer ijx;
  172.     } _1;
  173.     struct {
  174.     doublereal zpk, rkb2;
  175.     integer ij;
  176.     } _2;
  177. } tmi_;
  178.  
  179. #define tmi_1 (tmi_._1)
  180. #define tmi_2 (tmi_._2)
  181.  
  182. struct {
  183.     doublereal zpk, rhks;
  184. } tmh_;
  185.  
  186. #define tmh_1 tmh_
  187.  
  188. /* Table of constant values */
  189.  
  190. static integer c__1 = 1;
  191. static doublecomplex c_b48 = {1.,0.};
  192. static integer c__880 = 880;
  193. static integer c__680 = 680;
  194. static integer c__576 = 576;
  195. static integer c__2 = 2;
  196. static integer c__3 = 3;
  197. static integer c__11 = 11;
  198. static integer c__12 = 12;
  199. static integer c__13 = 13;
  200. static integer c__14 = 14;
  201. static integer c__7 = 7;
  202. static integer c__5 = 5;
  203. static integer c__0 = 0;
  204. static integer c_n1 = -1;
  205. static integer c__31 = 31;
  206. static doublereal c_b594 = 0.;
  207. static integer c__16 = 16;
  208. static integer c__17 = 17;
  209. static integer c__18 = 18;
  210. static integer c__19 = 19;
  211. static integer c__20 = 20;
  212. static integer c__602 = 602;
  213. static integer c__193 = 193;
  214. static doublecomplex c_b1190 = {.5,0.};
  215. static integer c__95 = 95;
  216. static integer c__206 = 206;
  217. static integer c__205 = 205;
  218. static integer c__201 = 201;
  219. static integer c__202 = 202;
  220. static integer c__203 = 203;
  221. static integer c__204 = 204;
  222. static integer c__207 = 207;
  223. static integer c__208 = 208;
  224. static integer c__4 = 4;
  225. static integer c__121 = 121;
  226. static integer c__122 = 122;
  227. static integer c__123 = 123;
  228. static integer c__124 = 124;
  229. static integer c__125 = 125;
  230. static integer c__9 = 9;
  231.  
  232. /*     PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14, */
  233. /*    1TAPE15,TAPE16,TAPE20,TAPE21) */
  234.  
  235. /*     NUMERICAL ELECTROMAGNETICS CODE (NEC2)  DEVELOPED AT LAWRENCE */
  236. /*     LIVERMORE LAB., LIVERMORE, CA.  (CONTACT G. BURKE AT 415-422-8414 */
  237. /*     FOR PROBLEMS WITH THE NEC CODE.  FOR PROBLEMS WITH THE VAX IMPLEM- */
  238. /*     ENTATION, CONTACT J. BREAKALL AT 415-422-8196 OR E. DOMNING AT 415 */
  239. /*     422-5936) */
  240. /*     FILE CREATED 4/11/80. */
  241.  
  242. /*                ***********NOTICE********** */
  243. /*     THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK */
  244. /*     SPONSORED BY THE UNITED STATES GOVERNMENT.  NEITHER THE UNITED */
  245. /*     STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF */
  246. /*     THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR */
  247. /*     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR */
  248. /*     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, */
  249. /*     COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT */
  250. /*     OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT */
  251. /*     INFRINGE PRIVATELY-OWNED RIGHTS. */
  252.  
  253. /* *** */
  254. /* *** */
  255. /*     DOUBLE PRECISION 6/4/85 */
  256.  
  257. /* *** */
  258. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  259. /* Main program */ MAIN__()
  260. {
  261.     /* Initialized data */
  262.  
  263.     static char atst[2*22+1] = "CEFRLDGNEXNTXQNEGDRPCMNXENTLPTKHNHPQEKWGCPPL";
  264.  
  265.     static char hpol[6*3+1] = "LINEARRIGHT LEFT  ";
  266.     static char pnet[6*6+1] = "            STRAIGHT    CROSSED     ";
  267.     static doublereal ta = .01745329252;
  268.     static doublereal cvel = 299.8;
  269.     static integer loadmx = 200;
  270.     static integer nsmax = 150;
  271.     static integer netmx = 150;
  272.     static integer normf = 200;
  273.  
  274.     /* Format strings */
  275.     static char fmt_700[] = "(\002$ENTER DATA INPUT FILENAME [HIT RETURN FOR\
  276.  TERMINAL\002,\002 INPUT] : \002,/,\002$     >\002)";
  277.     static char fmt_701[] = "(a)";
  278.     static char fmt_703[] = "(\002$ENTER DATA OUTPUT FILENAME [HIT RETURN FO\
  279. R TERMINAL\002,\002 OUTPUT] : \002,/,\002$     >\002)";
  280.     static char fmt_125[] = "(a2,19a4)";
  281.     static char fmt_126[] = "(\0021\002)";
  282.     static char fmt_127[] = "(///,33x,\002**********************************\
  283. **\002,//,36x,\002NUMERICAL ELECTROMAGNETICS CODE\002,//,33x,\002***********\
  284. *************************\002)";
  285.     static char fmt_128[] = "(////,37x,\002- - - - COMMENTS - - - -\002,//)";
  286.     static char fmt_129[] = "(25x,20a4)";
  287.     static char fmt_130[] = "(///,10x,\002INCORRECT LABEL FOR A COMMENT CAR\
  288. D\002)";
  289.     static char fmt_135[] = "(/////)";
  290.     static char fmt_137[] = "(1x,\002***** DATA CARD NO.\002,i3,3x,a2,1x,i3,\
  291. 3(1x,i5),6(1x,1p,e12.5))";
  292.     static char fmt_201[] = "(/,\002 RUN TIME =\002,f10.3)";
  293.     static char fmt_138[] = "(///,10x,\002FAULTY DATA CARD LABEL AFTER GEOME\
  294. TRY SECTION\002)";
  295.     static char fmt_303[] = "(/,\002 ERROR - \002,a2,\002 CARD IS NOT ALLOWE\
  296. D WITH N.G.F.\002)";
  297.     static char fmt_313[] = "(/,\002 NUMBER OF SEGMENTS IN COUPLING CALCULAT\
  298. ION (CP) EXCEE\002,\002DS LIMIT\002)";
  299.     static char fmt_139[] = "(///,10x,\002NUMBER OF LOADING CARDS EXCEEDS ST\
  300. ORAGE ALLOTTED\002)";
  301.     static char fmt_140[] = "(///,10x,\002DATA FAULT ON LOADING CARD NO.=\
  302. \002,i5,5x,\002ITAG S\002,\002TEP1=\002,i5,\002  IS GREATER THAN ITAG STEP2\
  303. =\002,i5)";
  304.     static char fmt_390[] = "(\002 RADIAL WIRE G. S. APPROXIMATION MAY NOT B\
  305. E USED WITH SO\002,\002MMERFELD GROUND OPTION\002)";
  306.     static char fmt_141[] = "(///,10x,\002NUMBER OF EXCITATION CARDS EXCEEDS\
  307.  STORAGE ALLO\002,\002TTED\002)";
  308.     static char fmt_142[] = "(///,10x,\002NUMBER OF NETWORK CARDS EXCEEDS ST\
  309. ORAGE ALLOTTED\002)";
  310.     static char fmt_143[] = "(///,10x,\002WHEN MULTIPLE FREQUENCIES ARE REQU\
  311. ESTED, ONLY ONE  NEAR FIELD CARD CAN BE USED -\002,/,10x,\002LAST CARD READ \
  312. IS USED\002)";
  313.     static char fmt_302[] = "(\002 ERROR - N.G.F. IN USE.  CANNOT WRITE NEW \
  314. N.G.F.\002)";
  315.     static char fmt_145[] = "(////,33x,\002- - - - - - FREQUENCY - - - - - \
  316. -\002,//,36x,\002FR\002,\002EQUENCY=\002,1p,e11.4,\002 MHZ\002,/,36x,\002WAV\
  317. ELENGTH=\002,e11.4,\002 METERS\002)";
  318.     static char fmt_196[] = "(////,20x,\002APPROXIMATE INTEGRATION EMPLOYED \
  319. FOR SEGMENT\002,\002S MORE THAN\002,f8.3,\002 WAVELENGTHS APART\002)";
  320.     static char fmt_321[] = "(/,20x,\002THE EXTENDED THIN WIRE KERNEL WILL B\
  321. E USED\002)";
  322.     static char fmt_146[] = "(///,30x,\002 - - - STRUCTURE IMPEDANCE LOADING\
  323.  - - -\002)";
  324.     static char fmt_147[] = "(/,35x,\002THIS STRUCTURE IS NOT LOADED\002)";
  325.     static char fmt_327[] = "(/,35x,\002 LOADING ONLY IN N.G.F. SECTION\002)";
  326.  
  327.     static char fmt_148[] = "(///,34x,\002- - - ANTENNA ENVIRONMENT - - -\
  328. \002,/)";
  329.     static char fmt_170[] = "(40x,\002RADIAL WIRE GROUND SCREEN\002,/,40x,\
  330. i5,\002 WIRES\002,/,40x,\002WIRE LENGTH=\002,f8.2,\002 METERS\002,/,40x,\002\
  331. WIRE RADIUS=\002,1p,e10.3,\002 METERS\002)";
  332.     static char fmt_149[] = "(40x,\002MEDIUM UNDER SCREEN -\002)";
  333.     static char fmt_391[] = "(40x,\002FINITE GROUND.  REFLECTION COEFFICIENT\
  334.  APPROXIMATION\002)";
  335.     static char fmt_393[] = "(/,\002 ERROR IN GROUND PARAMETERS -\002,/,\002\
  336.  COMPLEX DIELECTRIC\002,\002 CONSTANT FROM FILE IS\002,1p,2e12.5,/,32x,\002R\
  337. EQUESTED\002,2e12.5)";
  338.     static char fmt_392[] = "(40x,\002FINITE GROUND.  SOMMERFELD SOLUTION\
  339. \002)";
  340.     static char fmt_150[] = "(40x,\002RELATIVE DIELECTRIC CONST.=\002,f7.3,/\
  341. ,40x,\002CONDUCTIV\002,\002ITY=\002,1p,e10.3,\002 MHOS/METER\002,/,40x,\002C\
  342. OMPLEX DIELECTRIC CONSTANT=\002,2e12.5)";
  343.     static char fmt_151[] = "(42x,\002PERFECT GROUND\002)";
  344.     static char fmt_152[] = "(44x,\002FREE SPACE\002)";
  345.     static char fmt_153[] = "(///,32x,\002- - - MATRIX TIMING - - -\002,//,2\
  346. 4x,\002FILL=\002,f9.3,\002 SEC.,  FACTOR=\002,f9.3,\002 SEC.\002)";
  347.     static char fmt_154[] = "(///,40x,\002- - - EXCITATION - - -\002)";
  348.     static char fmt_156[] = "(/,31x,\002POSITION (METERS)\002,14x,\002ORIENT\
  349. ATION (DEG)=/\002,28x,\002X\002,12x,\002Y\002,12x,\002Z\002,10x,\002ALPHA\
  350. \002,5x,\002BETA\002,4x,\002DIPOLE MOMENT\002,//,4x,\002CURRENT SOURCE\002,1\
  351. x,3(3x,f10.5),1x,2(3x,f7.2),4x,f8.3)";
  352.     static char fmt_155[] = "(/,4x,\002PLANE WAVE\002,4x,\002THETA=\002,f7\
  353. .2,\002 DEG,  PHI=\002,f7.2,\002 DEG,  ETA=\002,f7.2,\002 DEG,  TYPE -\002,a\
  354. 6,\002=  AXIAL RATIO=\002,f6.3)";
  355.     static char fmt_158[] = "(///,44x,\002- - - NETWORK DATA - - -\002)";
  356.     static char fmt_159[] = "(/,6x,\002- FROM -    - TO -\002,11x,\002TRANSM\
  357. ISSION LINE\002,15x,\002-  -  SHUNT ADMITTANCES (MHOS)  -  -\002,14x,\002LINE\
  358. \002,/,6x,\002TAG  SEG.\002,\002   TAG  SEG.\002,6x,\002IMPEDANCE\002,6x,\
  359. \002LENGTH\002,12x,\002- END ONE -\002,17x,\002- END TWO -\002,12x,\002TYP\
  360. E\002,/,6x,\002NO.   NO.   NO.   NO.\002,9x,\002OHM'S\002,8x,\002METERS\002,\
  361. 9x,\002REAL\002,10x,\002IMAG.\002,9x,\002REAL\002,10x,\002IMAG.\002)";
  362.     static char fmt_160[] = "(/,6x,\002- FROM -\002,4x,\002- TO -\002,26x\
  363. ,\002-  -  ADMITTANCE MATRIX\002,\002 ELEMENTS (MHOS)  -  -\002,/,6x,\002TAG\
  364.   SEG.   TAG  SEG.\002,13x,\002(ON\002,\002E,ONE)\002,19x,\002(ONE,TWO)\002,\
  365. 19x,\002(TWO,TWO)\002,/,6x,\002NO.   NO.   NO.\002,\002   NO.\002,8x,\002REAL\
  366. \002,10x,\002IMAG.\002,9x,\002REAL\002,10x,\002IMAG.\002,9x,\002REAL\002,10x,\
  367. \002IMAG.\002)";
  368.     static char fmt_157[] = "(4x,4(i5,1x),1p,6(3x,e11.4),3x,a6,a2)";
  369.     static char fmt_161[] = "(///,29x,\002- - - CURRENTS AND LOCATION - - \
  370. -\002,//,33x,\002DIS\002,\002TANCES IN WAVELENGTHS\002)";
  371.     static char fmt_162[] = "(//,2x,\002SEG.\002,2x,\002TAG\002,4x,\002COORD\
  372. . OF SEG. CENTER\002,5x,\002SEG.\002,12x,\002- - - CURRENT (AMPS) - - -\002,\
  373. /,2x,\002NO.\002,3x,\002NO.\002,5x,\002X\002,8x,\002Y\002,8x,\002Z\002,6x\
  374. ,\002LENGTH\002,5x,\002REAL\002,8x,\002IMAG.\002,7x,\002MAG.\002,8x,\002PHASE\
  375. \002)";
  376.     static char fmt_163[] = "(///,33x,\002- - - RECEIVING PATTERN PARAMETERS\
  377.  - - -\002,/,43x,\002ETA=\002,f7.2,\002 DEGREES\002,/,43x,\002TYPE -\002,a6,\
  378. /,43x,\002AXIAL RATIO=\002,f6.3,//,11x,\002THETA\002,6x,\002PHI\002,10x,\002\
  379. -  CURRENT  -\002,9x,\002SEG\002,/,11x,\002(DEG)\002,5x,\002(DEG)\002,7x,\
  380. \002MAGNITUDE\002,4x,\002PHASE\002,6x,\002NO.\002,/)";
  381.     static char fmt_164[] = "(10x,2(f7.2,3x),1x,1p,e11.4,3x,0p,f7.2,4x,i5)";
  382.     static char fmt_165[] = "(1x,2i5,3f9.4,f9.5,1x,1p,3e12.4,0p,f9.3)";
  383.     static char fmt_315[] = "(///,34x,\002- - - CHARGE DENSITIES - - -\002,/\
  384. /,36x,\002DISTANCES IN WAVELENGTHS\002,///,2x,\002SEG.\002,2x,\002TAG\002,4x,\
  385. \002COORD. OF SEG. CENTER\002,5x,\002SEG.\002,10x,\002CHARGE DENSITY (COULOM\
  386. BS/METER)\002,/,2x,\002NO.\002,3x,\002NO.\002,5x,\002X\002,8x,\002Y\002,8x\
  387. ,\002Z\002,6x,\002LENGTH\002,5x,\002REAL\002,8x,\002IMAG.\002,7x,\002MAG.\
  388. \002,8x,\002PHASE\002)";
  389.     static char fmt_197[] = "(////,41x,\002- - - - SURFACE PATCH CURRENTS - \
  390. - - -\002,//,50x,\002DISTANCE IN WAVELENGTHS\002,/,50x,\002CURRENT IN AMPS/M\
  391. ETER\002,//,28x,\002- - SURFACE COMPONENTS - -\002,19x,\002- - - RECTANGULAR\
  392.  COM\002,\002PONENTS - - -\002,/,6x,\002PATCH CENTER\002,6x,\002TANGENT VECT\
  393. OR 1\002,3x,\002TANGENT VECTOR 2\002,11x,\002X\002,19x,\002Y\002,19x,\002\
  394. Z\002,/,5x,\002X\002,6x,\002Y\002,6x,\002Z\002,5x,\002MAG.\002,7x,\002PHAS\
  395. E\002,3x,\002MAG.\002,7x,\002PHASE\002,3(4x,\002REAL\002,6x,\002IMAG.\002))";
  396.     static char fmt_198[] = "(1x,i4,/,1x,3f7.3,2(1p,e11.4,0p,f8.2),1p,6e10.2)"
  397.         ;
  398.     static char fmt_166[] = "(///,40x,\002- - - POWER BUDGET - - -\002,//,43\
  399. x,\002INPUT PO\002,\002WER   =\002,1p,e11.4,\002 WATTS\002,/,43x,\002RADIATE\
  400. D POWER=\002,e11.4,\002 WATTS\002,/,43x,\002STRUCTURE LOSS=\002,e11.4,\002 W\
  401. ATTS\002,/,43x,\002NETWORK LOSS  =\002,e11.4,\002 WATTS\002,/,43x,\002EFFICI\
  402. ENCY    =\002,0p,f7.2,\002 PERCENT\002)";
  403.     static char fmt_181[] = "(///,4x,\002RECEIVING PATTERN STORAGE TOO SMALL\
  404. ,ARRAY TRUNCA\002,\002TED\002)";
  405.     static char fmt_182[] = "(///,32x,\002- - - NORMALIZED RECEIVING PATTERN\
  406.  - - -\002,/,41x,\002NORMALIZATION FACTOR=\002,1p,e11.4,/,41x,\002ETA=\002,0\
  407. p,f7.2,\002 DEGREES\002,/,41x,\002TYPE -\002,a6,/,41x,\002AXIAL RATIO=\002,f\
  408. 6.3,/,41x,\002SEGMENT NO.=\002,i5,//,21x,\002THETA\002,6x,\002PHI\002,9x,\
  409. \002-  PATTERN  -\002,/,21x,\002(DEG)\002,5x,\002(DEG)\002,8x,\002DB\002,8x\
  410. ,\002MAGNITUDE\002,/)";
  411.     static char fmt_183[] = "(20x,2(f7.2,3x),1x,f7.2,4x,1p,e11.4)";
  412.     static char fmt_184[] = "(///,36x,\002- - - INPUT IMPEDANCE DATA - - \
  413. -\002,/,45x,\002SO\002,\002URCE SEGMENT NO.\002,i4,/,45x,\002NORMALIZATION F\
  414. ACTOR=\002,1p,e12.5,//,7x,\002FREQ.\002,13x,\002-  -  UNNORMALIZED IMPEDANCE\
  415.   -  -\002,21x,\002-\002\002 -  NORMALIZED IMPEDANCE  -  -\002,/,19x,\002RES\
  416. ISTANCE\002,4x,\002REACTA\002,\002NCE\002,6x,\002MAGNITUDE\002,4x,\002PHAS\
  417. E\002,7x,\002RESISTANCE\002,4x,\002REACTANCE\002,6x,\002MAGNITUDE\002,4x,\
  418. \002PHASE\002,/,8x,\002MHZ\002,11x,\002OHMS\002,10x,\002OHMS\002,11x,\002OHMS\
  419. \002,5x,\002DEGREES\002,47x,\002DEGREES\002,/)";
  420.     static char fmt_185[] = "(///,4x,\002STORAGE FOR IMPEDANCE NORMALIZATION\
  421.  TOO SMALL, A\002,\002RRAY TRUNCATED\002)";
  422.     static char fmt_186[] = "(3x,f9.3,2x,1p,2(2x,e12.5),3x,e12.5,2x,0p,f7.2,\
  423. 2x,1p,2(2x,e12.5),3x,e12.5,2x,0p,f7.2)";
  424.  
  425.     /* System generated locals */
  426.     integer i__1, i__2, i__3, i__4;
  427.     doublereal d__1, d__2, d__3, d__4;
  428.     doublecomplex z__1, z__2, z__3, z__4, z__5;
  429.     olist o__1;
  430.  
  431.     /* Builtin functions */
  432.     integer s_wsfe(), e_wsfe(), s_rsfe(), do_fio(), e_rsfe(), s_cmp(), f_open(
  433.         );
  434.     /* Subroutine */ int s_stop();
  435.     double z_abs();
  436.     void z_sqrt(), z_div();
  437.     integer s_rsue(), do_uio(), e_rsue();
  438.     double sqrt(), d_imag();
  439.     integer s_wsle(), do_lio(), e_wsle();
  440.     double pow_di();
  441.  
  442.     /* Local variables */
  443.     static doublereal cmag;
  444.     extern doublereal cang_();
  445.     static doublereal epha;
  446.     extern /* Subroutine */ int load_();
  447.     static integer iped;
  448.     static doublereal etha;
  449.     static doublecomplex epsc, curi;
  450.     static integer nfrq, iexk, ifrq, nthi, nphi, jump;
  451.     static doublereal ethm, ephm, fmhz1;
  452.     static integer itmp1, itmp2, itmp3, itmp4, itmp5;
  453.     extern /* Subroutine */ int facgf_();
  454.     static integer i, j;
  455.     extern /* Subroutine */ int fbngf_();
  456.     static integer ldtag[200];
  457.     extern /* Subroutine */ int cmngf_();
  458.     static integer nphic, iptag, irngf;
  459.     extern /* Subroutine */ int cmset_();
  460.     static doublereal fnorm[200];
  461.     static integer ldtyp[200];
  462.     static doublereal xtemp[600];
  463. #define x2 ((doublereal *)&data_1 + 1800)
  464. #define y2 ((doublereal *)&data_1 + 3000)
  465. #define z2 ((doublereal *)&data_1 + 3600)
  466.     static doublereal ytemp[600], ztemp[600];
  467.     extern /* Subroutine */ int error_();
  468.     static doublereal extim;
  469.     static integer mpcnt, iflow;
  470.     static doublereal fmhzs, phiss;
  471.     static integer iptaq;
  472.     extern /* Subroutine */ int gfout_();
  473.     static integer nthic;
  474.     extern /* Subroutine */ int etmns_(), netwk_();
  475.     static integer isave;
  476.     extern /* Subroutine */ int nfpat_(), rdpat_(), str0pc_();
  477.     static doublecomplex fj;
  478.     static doublereal fr;
  479.     static doublecomplex ex, ey, ez;
  480.     static integer ldtagf[200], ix[800];
  481.     static char infile[80];
  482.     extern /* Subroutine */ int datagn_(), readmn_(), fblock_();
  483.     static integer iptagf;
  484.     static doublereal ph, delfrq;
  485.     static integer ldtagt[200];
  486.     static doublereal bitemp[600];
  487.     extern /* Subroutine */ int secnds_();
  488.     static char otfile[80];
  489.     extern /* Subroutine */ int factrs_();
  490.     static integer iptflg;
  491.     extern integer isegno_();
  492.     static integer iptaqf, iptagt;
  493.     extern /* Subroutine */ int couple_();
  494.     static integer iptflq;
  495.     static doublereal thetis, sitemp[600];
  496.     static integer ifrtmp, iptaqt, ifrtmw, iresrv;
  497.     static doublereal fr2, zpnorm;
  498. #define t1x ((doublereal *)&data_1 + 1800)
  499. #define t1y ((doublereal *)&data_1 + 3000)
  500. #define t1z ((doublereal *)&data_1 + 3600)
  501. #define t2x ((doublereal *)&data_1 + 4201)
  502. #define t2y ((doublereal *)&data_1 + 4601)
  503. #define t2z ((doublereal *)&data_1 + 5001)
  504. #define cab ((doublereal *)&data_1 + 3000)
  505.     extern doublereal db20_();
  506.     static integer ib11, ic11, id11;
  507. #define sab ((doublereal *)&data_1 + 3600)
  508.     static char ain[2];
  509.     static integer inc;
  510.     static doublecomplex eph, eth;
  511.     static doublereal zlr[200], zli[200], zlc[200];
  512.     static integer ix11, igo;
  513.     static doublereal rkh;
  514.     static integer mhz;
  515.     static doublereal tim, tim1, tim2, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, 
  516.         xpr1, xpr2, xpr3, xpr4, xpr5;
  517.  
  518.     /* Fortran I/O blocks */
  519.     static cilist io___21 = { 0, 6, 0, fmt_700, 0 };
  520.     static cilist io___22 = { 1, 5, 0, fmt_701, 0 };
  521.     static cilist io___24 = { 0, 6, 0, fmt_703, 0 };
  522.     static cilist io___25 = { 1, 5, 0, fmt_701, 0 };
  523.     static cilist io___32 = { 0, 5, 0, fmt_125, 0 };
  524.     static cilist io___35 = { 0, 6, 0, fmt_126, 0 };
  525.     static cilist io___36 = { 0, 6, 0, fmt_127, 0 };
  526.     static cilist io___37 = { 0, 6, 0, fmt_128, 0 };
  527.     static cilist io___38 = { 0, 6, 0, fmt_129, 0 };
  528.     static cilist io___39 = { 0, 6, 0, fmt_130, 0 };
  529.     static cilist io___46 = { 0, 6, 0, fmt_135, 0 };
  530.     static cilist io___66 = { 0, 6, 0, fmt_137, 0 };
  531.     static cilist io___67 = { 0, 6, 0, fmt_201, 0 };
  532.     static cilist io___68 = { 0, 6, 0, fmt_138, 0 };
  533.     static cilist io___70 = { 0, 6, 0, fmt_303, 0 };
  534.     static cilist io___73 = { 0, 6, 0, fmt_313, 0 };
  535.     static cilist io___74 = { 0, 6, 0, fmt_139, 0 };
  536.     static cilist io___79 = { 0, 6, 0, fmt_140, 0 };
  537.     static cilist io___83 = { 0, 6, 0, fmt_303, 0 };
  538.     static cilist io___84 = { 0, 6, 0, fmt_390, 0 };
  539.     static cilist io___85 = { 0, 6, 0, fmt_141, 0 };
  540.     static cilist io___95 = { 0, 6, 0, fmt_142, 0 };
  541.     static cilist io___102 = { 0, 6, 0, fmt_143, 0 };
  542.     static cilist io___103 = { 0, 6, 0, fmt_302, 0 };
  543.     static cilist io___113 = { 0, 6, 0, fmt_145, 0 };
  544.     static cilist io___114 = { 0, 6, 0, fmt_196, 0 };
  545.     static cilist io___115 = { 0, 6, 0, fmt_321, 0 };
  546.     static cilist io___117 = { 0, 6, 0, fmt_146, 0 };
  547.     static cilist io___118 = { 0, 6, 0, fmt_147, 0 };
  548.     static cilist io___119 = { 0, 6, 0, fmt_327, 0 };
  549.     static cilist io___120 = { 0, 6, 0, fmt_148, 0 };
  550.     static cilist io___122 = { 0, 6, 0, fmt_170, 0 };
  551.     static cilist io___123 = { 0, 6, 0, fmt_149, 0 };
  552.     static cilist io___124 = { 0, 6, 0, fmt_391, 0 };
  553.     static cilist io___125 = { 0, 21, 0, 0, 0 };
  554.     static cilist io___126 = { 0, 6, 0, fmt_393, 0 };
  555.     static cilist io___127 = { 0, 6, 0, fmt_392, 0 };
  556.     static cilist io___128 = { 0, 6, 0, fmt_150, 0 };
  557.     static cilist io___129 = { 0, 6, 0, fmt_151, 0 };
  558.     static cilist io___130 = { 0, 6, 0, fmt_152, 0 };
  559.     static cilist io___135 = { 0, 6, 0, fmt_153, 0 };
  560.     static cilist io___139 = { 0, 6, 0, fmt_154, 0 };
  561.     static cilist io___140 = { 0, 6, 0, fmt_156, 0 };
  562.     static cilist io___141 = { 0, 6, 0, fmt_155, 0 };
  563.     static cilist io___142 = { 0, 6, 0, fmt_158, 0 };
  564.     static cilist io___143 = { 0, 6, 0, fmt_159, 0 };
  565.     static cilist io___144 = { 0, 6, 0, fmt_160, 0 };
  566.     static cilist io___146 = { 0, 6, 0, fmt_157, 0 };
  567.     static cilist io___148 = { 0, 6, 0, fmt_161, 0 };
  568.     static cilist io___149 = { 0, 6, 0, fmt_162, 0 };
  569.     static cilist io___150 = { 0, 6, 0, fmt_163, 0 };
  570.     static cilist io___156 = { 0, 6, 0, fmt_164, 0 };
  571.     static cilist io___157 = { 0, 6, 0, fmt_165, 0 };
  572.     static cilist io___158 = { 0, 8, 0, 0, 0 };
  573.     static cilist io___159 = { 0, 8, 0, 0, 0 };
  574.     static cilist io___160 = { 0, 6, 0, fmt_315, 0 };
  575.     static cilist io___161 = { 0, 6, 0, fmt_165, 0 };
  576.     static cilist io___162 = { 0, 6, 0, fmt_197, 0 };
  577.     static cilist io___172 = { 0, 6, 0, fmt_198, 0 };
  578.     static cilist io___173 = { 0, 8, 0, 0, 0 };
  579.     static cilist io___174 = { 0, 8, 0, 0, 0 };
  580.     static cilist io___175 = { 0, 8, 0, 0, 0 };
  581.     static cilist io___176 = { 0, 8, 0, 0, 0 };
  582.     static cilist io___177 = { 0, 6, 0, fmt_166, 0 };
  583.     static cilist io___178 = { 0, 6, 0, fmt_135, 0 };
  584.     static cilist io___179 = { 0, 6, 0, fmt_135, 0 };
  585.     static cilist io___180 = { 0, 6, 0, fmt_181, 0 };
  586.     static cilist io___181 = { 0, 6, 0, fmt_182, 0 };
  587.     static cilist io___182 = { 0, 6, 0, fmt_183, 0 };
  588.     static cilist io___183 = { 0, 6, 0, fmt_135, 0 };
  589.     static cilist io___184 = { 0, 6, 0, fmt_184, 0 };
  590.     static cilist io___185 = { 0, 6, 0, fmt_184, 0 };
  591.     static cilist io___186 = { 0, 6, 0, fmt_185, 0 };
  592.     static cilist io___187 = { 0, 6, 0, fmt_186, 0 };
  593.     static cilist io___188 = { 0, 6, 0, fmt_135, 0 };
  594.  
  595.  
  596. /*<       CHARACTER   AIN*2, ATST*2, INFILE*80, OTFILE*80 >*/
  597. /* *** */
  598. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  599. /*     INTEGER  AIN,ATST,PNET,HPOL */
  600. /*     REAL RHPOL,PNET */
  601. /*<    >*/
  602. /*<    >*/
  603. /*<       COMPLEX  AR1, AR2, AR3, EPSCF, FRATI >*/
  604. /*<       COMMON  /CMB/ CM(90000) >*/
  605. /*<    >*/
  606. /*<    >*/
  607. /*<       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
  608. /*<    >*/
  609. /*<    >*/
  610. /*<       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
  611. /*<    >*/
  612. /*<    >*/
  613. /*<    >*/
  614. /*<    >*/
  615. /*<    >*/
  616. /*<    >*/
  617. /* *** */
  618. /*<       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
  619. /* *** */
  620. /*<       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
  621. /*<       DIMENSION  CAB(1), SAB(1), X2(1), Y2(1), Z2(1) >*/
  622. /*<    >*/
  623. /*<       DIMENSION   IX( N2M) >*/
  624. /*<       DIMENSION  FNORM(200) >*/
  625. /* *** */
  626. /*<       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
  627. /*<    >*/
  628. /*<       EQUIVALENCE(CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET) >*/
  629. /*<    >*/
  630. /*<       CHARACTER*2 ATST(22) >*/
  631. /*<       CHARACTER*6 HPOL(3) >*/
  632. /*<       CHARACTER*6 PNET(6) >*/
  633. /*<    >*/
  634.  
  635.  
  636.  
  637. /*<       DATA   HPOL/6HLINEAR,5HRIGHT,4HLEFT/ >*/
  638.  
  639.  
  640. /*<       DATA   PNET/6H      ,2H  ,6HSTRAIG,2HHT,6HCROSSE,1HD/ >*/
  641. /*<       DATA   TA/1.745329252D-02/, CVEL/299.8/ >*/
  642. /* *** */
  643. /*<       DATA   LOADMX, NSMAX, NETMX/200,150,150/, NORMF/200/ >*/
  644. /*<   706 CONTINUE >*/
  645. L706:
  646. /*<       PRINT700  >*/
  647.     s_wsfe(&io___21);
  648.     e_wsfe();
  649. /*<    >*/
  650. /*<   701 FORMAT(A) >*/
  651. /* L701: */
  652. /*<       READ( *,701,ERR=702)  INFILE >*/
  653.     i__1 = s_rsfe(&io___22);
  654.     if (i__1 != 0) {
  655.     goto L702;
  656.     }
  657.     i__1 = do_fio(&c__1, infile, 80L);
  658.     if (i__1 != 0) {
  659.     goto L702;
  660.     }
  661.     i__1 = e_rsfe();
  662.     if (i__1 != 0) {
  663.     goto L702;
  664.     }
  665. /*<       CALL STR0PC( INFILE, INFILE) >*/
  666.     str0pc_(infile, infile, 80L, 80L);
  667. /* JCB   OPEN (UNIT=5,FILE=INFILE,STATUS='OLD',READONLY,ERR=702) */
  668. /*<       IF( INFILE.NE.' ') THEN >*/
  669.     if (s_cmp(infile, " ", 80L, 1L) != 0) {
  670. /*<       OPEN ( UNIT=5,FILE=INFILE,STATUS='OLD',ERR=702,BLANK='NULL') >*/
  671.     o__1.oerr = 1;
  672.     o__1.ounit = 5;
  673.     o__1.ofnmlen = 80;
  674.     o__1.ofnm = infile;
  675.     o__1.orl = 0;
  676.     o__1.osta = "OLD";
  677.     o__1.oacc = 0;
  678.     o__1.ofm = 0;
  679.     o__1.oblnk = "NULL";
  680.     i__1 = f_open(&o__1);
  681.     if (i__1 != 0) {
  682.         goto L702;
  683.     }
  684. /*<       ENDIF >*/
  685.     }
  686. /*<   707 CONTINUE >*/
  687. L707:
  688. /*<       PRINT703  >*/
  689.     s_wsfe(&io___24);
  690.     e_wsfe();
  691. /*<    >*/
  692. /*<       READ( *,701,ERR=704)  OTFILE >*/
  693.     i__1 = s_rsfe(&io___25);
  694.     if (i__1 != 0) {
  695.     goto L704;
  696.     }
  697.     i__1 = do_fio(&c__1, otfile, 80L);
  698.     if (i__1 != 0) {
  699.     goto L704;
  700.     }
  701.     i__1 = e_rsfe();
  702.     if (i__1 != 0) {
  703.     goto L704;
  704.     }
  705. /*<       CALL STR0PC( OTFILE, OTFILE) >*/
  706.     str0pc_(otfile, otfile, 80L, 80L);
  707. /*<       IF( OTFILE.NE.' ') THEN >*/
  708.     if (s_cmp(otfile, " ", 80L, 1L) != 0) {
  709. /*<       OPEN ( UNIT=6,FILE=OTFILE,STATUS='NEW',ERR=704) >*/
  710.     o__1.oerr = 1;
  711.     o__1.ounit = 6;
  712.     o__1.ofnmlen = 80;
  713.     o__1.ofnm = otfile;
  714.     o__1.orl = 0;
  715.     o__1.osta = "NEW";
  716.     o__1.oacc = 0;
  717.     o__1.ofm = 0;
  718.     o__1.oblnk = 0;
  719.     i__1 = f_open(&o__1);
  720.     if (i__1 != 0) {
  721.         goto L704;
  722.     }
  723. /*<       ENDIF >*/
  724.     }
  725. /*<       GOTO 705 >*/
  726.     goto L705;
  727. /*<   702 CALL ERROR >*/
  728. L702:
  729.     error_();
  730. /*<       GOTO 706 >*/
  731.     goto L706;
  732. /*<   704 CALL ERROR >*/
  733. L704:
  734.     error_();
  735. /*<       GOTO 707 >*/
  736.     goto L707;
  737. /* *** */
  738. /*<   705 CONTINUE >*/
  739. L705:
  740. /*<       CALL SECNDS(EXTIM) >*/
  741.     secnds_(&extim);
  742. /*<       FJ=(0.,1.) >*/
  743.     fj.r = 0., fj.i = 1.;
  744. /*<       LD=600 >*/
  745.     data_1.ld = 600;
  746. /*<       NXA(1)=0 >*/
  747.     ggrid_1.nxa[0] = 0;
  748. /*<       IRESRV=90000 >*/
  749.     iresrv = 90000;
  750. /* *** */
  751. /*<     1 KCOM=0 >*/
  752. L1:
  753.     save_1.kcom = 0;
  754. /*<       IFRTMW=0 >*/
  755.     ifrtmw = 0;
  756. /* *** */
  757. /*<       IFRTMP=0 >*/
  758.     ifrtmp = 0;
  759. /*<     2 KCOM= KCOM+1 >*/
  760. L2:
  761.     ++save_1.kcom;
  762. /*<       IF( KCOM.GT.5) KCOM=5 >*/
  763.     if (save_1.kcom > 5) {
  764.     save_1.kcom = 5;
  765.     }
  766. /* *** */
  767. /*<       READ( 5,125)  AIN,( COM( I, KCOM), I=1,19) >*/
  768.     s_rsfe(&io___32);
  769.     do_fio(&c__1, ain, 2L);
  770.     for (i = 1; i <= 19; ++i) {
  771.     do_fio(&c__1, (char *)&save_1.com[i + save_1.kcom * 19 - 20], (ftnlen)
  772.         sizeof(doublereal));
  773.     }
  774.     e_rsfe();
  775. /* *** */
  776. /*<       CALL STR0PC( AIN, AIN) >*/
  777.     str0pc_(ain, ain, 2L, 2L);
  778. /*<       IF( KCOM.GT.1) GOTO 3 >*/
  779.     if (save_1.kcom > 1) {
  780.     goto L3;
  781.     }
  782. /*<       WRITE( 6,126)  >*/
  783.     s_wsfe(&io___35);
  784.     e_wsfe();
  785. /*<       WRITE( 6,127)  >*/
  786.     s_wsfe(&io___36);
  787.     e_wsfe();
  788. /*<       WRITE( 6,128)  >*/
  789.     s_wsfe(&io___37);
  790.     e_wsfe();
  791. /*<     3 WRITE( 6,129) ( COM( I, KCOM), I=1,19) >*/
  792. L3:
  793.     s_wsfe(&io___38);
  794.     for (i = 1; i <= 19; ++i) {
  795.     do_fio(&c__1, (char *)&save_1.com[i + save_1.kcom * 19 - 20], (ftnlen)
  796.         sizeof(doublereal));
  797.     }
  798.     e_wsfe();
  799. /*<       IF( AIN.EQ. ATST(11)) GOTO 2 >*/
  800.     if (s_cmp(ain, atst + 20, 2L, 2L) == 0) {
  801.     goto L2;
  802.     }
  803. /*<       IF( AIN.EQ. ATST(1)) GOTO 4 >*/
  804.     if (s_cmp(ain, atst, 2L, 2L) == 0) {
  805.     goto L4;
  806.     }
  807. /*<       WRITE( 6,130)  >*/
  808.     s_wsfe(&io___39);
  809.     e_wsfe();
  810. /*<       STOP >*/
  811.     s_stop("", 0L);
  812. /*<     4 CONTINUE >*/
  813. L4:
  814. /*<       DO 5  I=1, LD >*/
  815.     i__1 = data_1.ld;
  816.     for (i = 1; i <= i__1; ++i) {
  817. /*<     5 ZARRAY( I)=(0.,0.) >*/
  818. /* L5: */
  819.     i__2 = i - 1;
  820.     zload_1.zarray[i__2].r = 0., zload_1.zarray[i__2].i = 0.;
  821.     }
  822. /*<       MPCNT=0 >*/
  823.     mpcnt = 0;
  824.  
  825. /*     SET UP GEOMETRY DATA IN SUBROUTINE DATAGN */
  826.  
  827. /*<       IMAT=0 >*/
  828.     matpar_1.imat = 0;
  829. /*<       CALL DATAGN >*/
  830.     datagn_();
  831. /*<       IFLOW=1 >*/
  832.     iflow = 1;
  833.  
  834. /*     CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION */
  835.  
  836. /*<       IF( IMAT.EQ.0) GOTO 326 >*/
  837.     if (matpar_1.imat == 0) {
  838.     goto L326;
  839.     }
  840. /*<       NEQ= N1+2* M1 >*/
  841.     netcx_1.neq = data_1.n1 + (data_1.m1 << 1);
  842. /*<       NEQ2= N- N1+2*( M- M1)+ NSCON+2* NPCON >*/
  843.     netcx_1.neq2 = data_1.n - data_1.n1 + (data_1.m - data_1.m1 << 1) + 
  844.         segj_1.nscon + (segj_1.npcon << 1);
  845. /*<       CALL FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11) >*/
  846.     fbngf_(&netcx_1.neq, &netcx_1.neq2, &iresrv, &ib11, &ic11, &id11, &ix11);
  847. /*<       GOTO 6 >*/
  848.     goto L6;
  849. /*<   326 NEQ= N+2* M >*/
  850. L326:
  851.     netcx_1.neq = data_1.n + (data_1.m << 1);
  852. /*<       NEQ2=0 >*/
  853.     netcx_1.neq2 = 0;
  854. /*<       IB11=1 >*/
  855.     ib11 = 1;
  856. /*<       IC11=1 >*/
  857.     ic11 = 1;
  858. /*<       ID11=1 >*/
  859.     id11 = 1;
  860. /*<       IX11=1 >*/
  861.     ix11 = 1;
  862. /*<       ICASX=0 >*/
  863.     matpar_1.icasx = 0;
  864. /*<     6 NPEQ= NP+2* MP >*/
  865. L6:
  866.     netcx_1.npeq = data_1.np + (data_1.mp << 1);
  867.  
  868. /*     DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS */
  869.  
  870. /* *** */
  871. /*<       WRITE( 6,135)  >*/
  872.     s_wsfe(&io___46);
  873.     e_wsfe();
  874. /*<       IPLP1=0 >*/
  875.     plot_1.iplp1 = 0;
  876. /*<       IPLP2=0 >*/
  877.     plot_1.iplp2 = 0;
  878. /*<       IPLP3=0 >*/
  879.     plot_1.iplp3 = 0;
  880. /* *** */
  881. /*<       IPLP4=0 >*/
  882.     plot_1.iplp4 = 0;
  883. /*<       IGO=1 >*/
  884.     igo = 1;
  885. /*<       FMHZS= CVEL >*/
  886.     fmhzs = cvel;
  887. /*<       NFRQ=1 >*/
  888.     nfrq = 1;
  889. /*<       RKH=1. >*/
  890.     rkh = 1.;
  891. /*<       IEXK=0 >*/
  892.     iexk = 0;
  893. /*<       IXTYP=0 >*/
  894.     fpat_1.ixtyp = 0;
  895. /*<       NLOAD=0 >*/
  896.     zload_1.nload = 0;
  897. /*<       NONET=0 >*/
  898.     netcx_1.nonet = 0;
  899. /*<       NEAR=-1 >*/
  900.     fpat_1.near = -1;
  901. /*<       IPTFLG=-2 >*/
  902.     iptflg = -2;
  903. /*<       IPTFLQ=-1 >*/
  904.     iptflq = -1;
  905. /*<       IFAR=-1 >*/
  906.     gnd_1.ifar = -1;
  907. /*<       ZRATI=(1.,0.) >*/
  908.     gnd_1.zrati.r = 1., gnd_1.zrati.i = 0.;
  909. /*<       IPED=0 >*/
  910.     iped = 0;
  911. /*<       IRNGF=0 >*/
  912.     irngf = 0;
  913. /*<       NCOUP=0 >*/
  914.     yparm_1.ncoup = 0;
  915. /*<       ICOUP=0 >*/
  916.     yparm_1.icoup = 0;
  917. /*<       IF( ICASX.GT.0) GOTO 14 >*/
  918.     if (matpar_1.icasx > 0) {
  919.     goto L14;
  920.     }
  921. /*<       FMHZ= CVEL >*/
  922.     save_1.fmhz = cvel;
  923. /*<       NLODF=0 >*/
  924.     zload_1.nlodf = 0;
  925. /*<       KSYMP=1 >*/
  926.     gnd_1.ksymp = 1;
  927. /*<       NRADL=0 >*/
  928.     gnd_1.nradl = 0;
  929.  
  930. /*     MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO- */
  931. /*     PRIATE SECTION FOR SPECIFIC PARAMETER SET UP */
  932.  
  933. /* 14    READ(5,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5, 
  934. */
  935. /*     1TMP6 */
  936. /* *** */
  937. /*<       IPERF=0 >*/
  938.     gnd_1.iperf = 0;
  939. /* *** */
  940. /*<    >*/
  941. L14:
  942.     readmn_(ain, &itmp1, &itmp2, &itmp3, &itmp4, &tmp1, &tmp2, &tmp3, &tmp4, &
  943.         tmp5, &tmp6, 2L);
  944. /*<       MPCNT= MPCNT+1 >*/
  945.     ++mpcnt;
  946. /*<    >*/
  947.     s_wsfe(&io___66);
  948.     do_fio(&c__1, (char *)&mpcnt, (ftnlen)sizeof(integer));
  949.     do_fio(&c__1, ain, 2L);
  950.     do_fio(&c__1, (char *)&itmp1, (ftnlen)sizeof(integer));
  951.     do_fio(&c__1, (char *)&itmp2, (ftnlen)sizeof(integer));
  952.     do_fio(&c__1, (char *)&itmp3, (ftnlen)sizeof(integer));
  953.     do_fio(&c__1, (char *)&itmp4, (ftnlen)sizeof(integer));
  954.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  955.     do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  956.     do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
  957.     do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
  958.     do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
  959.     do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
  960.     e_wsfe();
  961. /*<       IF( AIN.EQ. ATST(2)) GOTO 16 >*/
  962.     if (s_cmp(ain, atst + 2, 2L, 2L) == 0) {
  963.     goto L16;
  964.     }
  965. /*<       IF( AIN.EQ. ATST(3)) GOTO 17 >*/
  966.     if (s_cmp(ain, atst + 4, 2L, 2L) == 0) {
  967.     goto L17;
  968.     }
  969. /*<       IF( AIN.EQ. ATST(4)) GOTO 21 >*/
  970.     if (s_cmp(ain, atst + 6, 2L, 2L) == 0) {
  971.     goto L21;
  972.     }
  973. /*<       IF( AIN.EQ. ATST(5)) GOTO 24 >*/
  974.     if (s_cmp(ain, atst + 8, 2L, 2L) == 0) {
  975.     goto L24;
  976.     }
  977. /*<       IF( AIN.EQ. ATST(6)) GOTO 28 >*/
  978.     if (s_cmp(ain, atst + 10, 2L, 2L) == 0) {
  979.     goto L28;
  980.     }
  981. /*<       IF( AIN.EQ. ATST(14)) GOTO 28 >*/
  982.     if (s_cmp(ain, atst + 26, 2L, 2L) == 0) {
  983.     goto L28;
  984.     }
  985. /*<       IF( AIN.EQ. ATST(15)) GOTO 31 >*/
  986.     if (s_cmp(ain, atst + 28, 2L, 2L) == 0) {
  987.     goto L31;
  988.     }
  989. /*<       IF( AIN.EQ. ATST(18)) GOTO 319 >*/
  990.     if (s_cmp(ain, atst + 34, 2L, 2L) == 0) {
  991.     goto L319;
  992.     }
  993. /*<       IF( AIN.EQ. ATST(7)) GOTO 37 >*/
  994.     if (s_cmp(ain, atst + 12, 2L, 2L) == 0) {
  995.     goto L37;
  996.     }
  997. /*<       IF( AIN.EQ. ATST(8)) GOTO 32 >*/
  998.     if (s_cmp(ain, atst + 14, 2L, 2L) == 0) {
  999.     goto L32;
  1000.     }
  1001. /*<       IF( AIN.EQ. ATST(17)) GOTO 208 >*/
  1002.     if (s_cmp(ain, atst + 32, 2L, 2L) == 0) {
  1003.     goto L208;
  1004.     }
  1005. /*<       IF( AIN.EQ. ATST(9)) GOTO 34 >*/
  1006.     if (s_cmp(ain, atst + 16, 2L, 2L) == 0) {
  1007.     goto L34;
  1008.     }
  1009. /*<       IF( AIN.EQ. ATST(10)) GOTO 36 >*/
  1010.     if (s_cmp(ain, atst + 18, 2L, 2L) == 0) {
  1011.     goto L36;
  1012.     }
  1013. /*<       IF( AIN.EQ. ATST(16)) GOTO 305 >*/
  1014.     if (s_cmp(ain, atst + 30, 2L, 2L) == 0) {
  1015.     goto L305;
  1016.     }
  1017. /*<       IF( AIN.EQ. ATST(19)) GOTO 320 >*/
  1018.     if (s_cmp(ain, atst + 36, 2L, 2L) == 0) {
  1019.     goto L320;
  1020.     }
  1021. /*<       IF( AIN.EQ. ATST(12)) GOTO 1 >*/
  1022.     if (s_cmp(ain, atst + 22, 2L, 2L) == 0) {
  1023.     goto L1;
  1024.     }
  1025. /*<       IF( AIN.EQ. ATST(20)) GOTO 322 >*/
  1026.     if (s_cmp(ain, atst + 38, 2L, 2L) == 0) {
  1027.     goto L322;
  1028.     }
  1029. /* *** */
  1030. /*<       IF( AIN.EQ. ATST(21)) GOTO 304 >*/
  1031.     if (s_cmp(ain, atst + 40, 2L, 2L) == 0) {
  1032.     goto L304;
  1033.     }
  1034. /* *** */
  1035. /*<       IF( AIN.EQ. ATST(22)) GOTO 330 >*/
  1036.     if (s_cmp(ain, atst + 42, 2L, 2L) == 0) {
  1037.     goto L330;
  1038.     }
  1039. /*<       IF( AIN.NE. ATST(13)) GOTO 15 >*/
  1040.     if (s_cmp(ain, atst + 24, 2L, 2L) != 0) {
  1041.     goto L15;
  1042.     }
  1043. /*<       CALL SECNDS( TMP1) >*/
  1044.     secnds_(&tmp1);
  1045. /*<       TMP1= TMP1- EXTIM >*/
  1046.     tmp1 -= extim;
  1047. /*<       WRITE( 6,201)  TMP1 >*/
  1048.     s_wsfe(&io___67);
  1049.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  1050.     e_wsfe();
  1051. /*<       STOP >*/
  1052.     s_stop("", 0L);
  1053. /*<    15 WRITE( 6,138)  >*/
  1054. L15:
  1055.     s_wsfe(&io___68);
  1056.     e_wsfe();
  1057.  
  1058. /*     FREQUENCY PARAMETERS */
  1059.  
  1060. /*<       STOP >*/
  1061.     s_stop("", 0L);
  1062. /*<    16 IFRQ= ITMP1 >*/
  1063. L16:
  1064.     ifrq = itmp1;
  1065. /*<       IF( ICASX.EQ.0) GOTO 8 >*/
  1066.     if (matpar_1.icasx == 0) {
  1067.     goto L8;
  1068.     }
  1069. /*<       WRITE( 6,303)  AIN >*/
  1070.     s_wsfe(&io___70);
  1071.     do_fio(&c__1, ain, 2L);
  1072.     e_wsfe();
  1073. /*<       STOP >*/
  1074.     s_stop("", 0L);
  1075. /*<     8 NFRQ= ITMP2 >*/
  1076. L8:
  1077.     nfrq = itmp2;
  1078. /*<       IF( NFRQ.EQ.0) NFRQ=1 >*/
  1079.     if (nfrq == 0) {
  1080.     nfrq = 1;
  1081.     }
  1082. /*<       FMHZ= TMP1 >*/
  1083.     save_1.fmhz = tmp1;
  1084. /*<       DELFRQ= TMP2 >*/
  1085.     delfrq = tmp2;
  1086. /*<       IF( IPED.EQ.1) ZPNORM=0. >*/
  1087.     if (iped == 1) {
  1088.     zpnorm = 0.;
  1089.     }
  1090. /*<       IGO=1 >*/
  1091.     igo = 1;
  1092. /*<       IFLOW=1 >*/
  1093.     iflow = 1;
  1094.  
  1095. /*     MATRIX INTEGRATION LIMIT */
  1096.  
  1097. /*<       GOTO 14 >*/
  1098.     goto L14;
  1099. /*<   305 RKH= TMP1 >*/
  1100. L305:
  1101.     rkh = tmp1;
  1102. /*<       IF( IGO.GT.2) IGO=2 >*/
  1103.     if (igo > 2) {
  1104.     igo = 2;
  1105.     }
  1106. /*<       IFLOW=1 >*/
  1107.     iflow = 1;
  1108.  
  1109. /*     EXTENDED THIN WIRE KERNEL OPTION */
  1110.  
  1111. /*<       GOTO 14 >*/
  1112.     goto L14;
  1113. /*<   320 IEXK=1 >*/
  1114. L320:
  1115.     iexk = 1;
  1116. /*<       IF( ITMP1.EQ.-1) IEXK=0 >*/
  1117.     if (itmp1 == -1) {
  1118.     iexk = 0;
  1119.     }
  1120. /*<       IF( IGO.GT.2) IGO=2 >*/
  1121.     if (igo > 2) {
  1122.     igo = 2;
  1123.     }
  1124. /*<       IFLOW=1 >*/
  1125.     iflow = 1;
  1126.  
  1127. /*     MAXIMUM COUPLING BETWEEN ANTENNAS */
  1128.  
  1129. /*<       GOTO 14 >*/
  1130.     goto L14;
  1131. /*<   304 IF( IFLOW.NE.2) NCOUP=0 >*/
  1132. L304:
  1133.     if (iflow != 2) {
  1134.     yparm_1.ncoup = 0;
  1135.     }
  1136. /*<       ICOUP=0 >*/
  1137.     yparm_1.icoup = 0;
  1138. /*<       IFLOW=2 >*/
  1139.     iflow = 2;
  1140. /*<       IF( ITMP2.EQ.0) GOTO 14 >*/
  1141.     if (itmp2 == 0) {
  1142.     goto L14;
  1143.     }
  1144. /*<       NCOUP= NCOUP+1 >*/
  1145.     ++yparm_1.ncoup;
  1146. /*<       IF( NCOUP.GT.5) GOTO 312 >*/
  1147.     if (yparm_1.ncoup > 5) {
  1148.     goto L312;
  1149.     }
  1150. /*<       NCTAG( NCOUP)= ITMP1 >*/
  1151.     yparm_1.nctag[yparm_1.ncoup - 1] = itmp1;
  1152. /*<       NCSEG( NCOUP)= ITMP2 >*/
  1153.     yparm_1.ncseg[yparm_1.ncoup - 1] = itmp2;
  1154. /*<       IF( ITMP4.EQ.0) GOTO 14 >*/
  1155.     if (itmp4 == 0) {
  1156.     goto L14;
  1157.     }
  1158. /*<       NCOUP= NCOUP+1 >*/
  1159.     ++yparm_1.ncoup;
  1160. /*<       IF( NCOUP.GT.5) GOTO 312 >*/
  1161.     if (yparm_1.ncoup > 5) {
  1162.     goto L312;
  1163.     }
  1164. /*<       NCTAG( NCOUP)= ITMP3 >*/
  1165.     yparm_1.nctag[yparm_1.ncoup - 1] = itmp3;
  1166. /*<       NCSEG( NCOUP)= ITMP4 >*/
  1167.     yparm_1.ncseg[yparm_1.ncoup - 1] = itmp4;
  1168. /*<       GOTO 14 >*/
  1169.     goto L14;
  1170. /*<   312 WRITE( 6,313)  >*/
  1171. L312:
  1172.     s_wsfe(&io___73);
  1173.     e_wsfe();
  1174.  
  1175. /*     LOADING PARAMETERS */
  1176.  
  1177. /*<       STOP >*/
  1178.     s_stop("", 0L);
  1179. /*<    17 IF( IFLOW.EQ.3) GOTO 18 >*/
  1180. L17:
  1181.     if (iflow == 3) {
  1182.     goto L18;
  1183.     }
  1184. /*<       NLOAD=0 >*/
  1185.     zload_1.nload = 0;
  1186. /*<       IFLOW=3 >*/
  1187.     iflow = 3;
  1188. /*<       IF( IGO.GT.2) IGO=2 >*/
  1189.     if (igo > 2) {
  1190.     igo = 2;
  1191.     }
  1192. /*<       IF( ITMP1.EQ.(-1)) GOTO 14 >*/
  1193.     if (itmp1 == -1) {
  1194.     goto L14;
  1195.     }
  1196. /*<    18 NLOAD= NLOAD+1 >*/
  1197. L18:
  1198.     ++zload_1.nload;
  1199. /*<       IF( NLOAD.LE. LOADMX) GOTO 19 >*/
  1200.     if (zload_1.nload <= loadmx) {
  1201.     goto L19;
  1202.     }
  1203. /*<       WRITE( 6,139)  >*/
  1204.     s_wsfe(&io___74);
  1205.     e_wsfe();
  1206. /*<       STOP >*/
  1207.     s_stop("", 0L);
  1208. /*<    19 LDTYP( NLOAD)= ITMP1 >*/
  1209. L19:
  1210.     ldtyp[zload_1.nload - 1] = itmp1;
  1211. /*<       LDTAG( NLOAD)= ITMP2 >*/
  1212.     ldtag[zload_1.nload - 1] = itmp2;
  1213. /*<       IF( ITMP4.EQ.0) ITMP4= ITMP3 >*/
  1214.     if (itmp4 == 0) {
  1215.     itmp4 = itmp3;
  1216.     }
  1217. /*<       LDTAGF( NLOAD)= ITMP3 >*/
  1218.     ldtagf[zload_1.nload - 1] = itmp3;
  1219. /*<       LDTAGT( NLOAD)= ITMP4 >*/
  1220.     ldtagt[zload_1.nload - 1] = itmp4;
  1221. /*<       IF( ITMP4.GE. ITMP3) GOTO 20 >*/
  1222.     if (itmp4 >= itmp3) {
  1223.     goto L20;
  1224.     }
  1225. /*<       WRITE( 6,140)  NLOAD, ITMP3, ITMP4 >*/
  1226.     s_wsfe(&io___79);
  1227.     do_fio(&c__1, (char *)&zload_1.nload, (ftnlen)sizeof(integer));
  1228.     do_fio(&c__1, (char *)&itmp3, (ftnlen)sizeof(integer));
  1229.     do_fio(&c__1, (char *)&itmp4, (ftnlen)sizeof(integer));
  1230.     e_wsfe();
  1231. /*<       STOP >*/
  1232.     s_stop("", 0L);
  1233. /*<    20 ZLR( NLOAD)= TMP1 >*/
  1234. L20:
  1235.     zlr[zload_1.nload - 1] = tmp1;
  1236. /*<       ZLI( NLOAD)= TMP2 >*/
  1237.     zli[zload_1.nload - 1] = tmp2;
  1238. /*<       ZLC( NLOAD)= TMP3 >*/
  1239.     zlc[zload_1.nload - 1] = tmp3;
  1240.  
  1241. /*     GROUND PARAMETERS UNDER THE ANTENNA */
  1242.  
  1243. /*<       GOTO 14 >*/
  1244.     goto L14;
  1245. /*<    21 IFLOW=4 >*/
  1246. L21:
  1247.     iflow = 4;
  1248. /*<       IF( ICASX.EQ.0) GOTO 10 >*/
  1249.     if (matpar_1.icasx == 0) {
  1250.     goto L10;
  1251.     }
  1252. /*<       WRITE( 6,303)  AIN >*/
  1253.     s_wsfe(&io___83);
  1254.     do_fio(&c__1, ain, 2L);
  1255.     e_wsfe();
  1256. /*<       STOP >*/
  1257.     s_stop("", 0L);
  1258. /*<    10 IF( IGO.GT.2) IGO=2 >*/
  1259. L10:
  1260.     if (igo > 2) {
  1261.     igo = 2;
  1262.     }
  1263. /*<       IF( ITMP1.NE.(-1)) GOTO 22 >*/
  1264.     if (itmp1 != -1) {
  1265.     goto L22;
  1266.     }
  1267. /*<       KSYMP=1 >*/
  1268.     gnd_1.ksymp = 1;
  1269. /*<       NRADL=0 >*/
  1270.     gnd_1.nradl = 0;
  1271. /*<       IPERF=0 >*/
  1272.     gnd_1.iperf = 0;
  1273. /*<       GOTO 14 >*/
  1274.     goto L14;
  1275. /*<    22 IPERF= ITMP1 >*/
  1276. L22:
  1277.     gnd_1.iperf = itmp1;
  1278. /*<       NRADL= ITMP2 >*/
  1279.     gnd_1.nradl = itmp2;
  1280. /*<       KSYMP=2 >*/
  1281.     gnd_1.ksymp = 2;
  1282. /*<       EPSR= TMP1 >*/
  1283.     save_1.epsr = tmp1;
  1284. /*<       SIG= TMP2 >*/
  1285.     save_1.sig = tmp2;
  1286. /*<       IF( NRADL.EQ.0) GOTO 23 >*/
  1287.     if (gnd_1.nradl == 0) {
  1288.     goto L23;
  1289.     }
  1290. /*<       IF( IPERF.NE.2) GOTO 314 >*/
  1291.     if (gnd_1.iperf != 2) {
  1292.     goto L314;
  1293.     }
  1294. /*<       WRITE( 6,390)  >*/
  1295.     s_wsfe(&io___84);
  1296.     e_wsfe();
  1297. /*<       STOP >*/
  1298.     s_stop("", 0L);
  1299. /*<   314 SCRWLT= TMP3 >*/
  1300. L314:
  1301.     save_1.scrwlt = tmp3;
  1302. /*<       SCRWRT= TMP4 >*/
  1303.     save_1.scrwrt = tmp4;
  1304. /*<       GOTO 14 >*/
  1305.     goto L14;
  1306. /*<    23 EPSR2= TMP3 >*/
  1307. L23:
  1308.     fpat_1.epsr2 = tmp3;
  1309. /*<       SIG2= TMP4 >*/
  1310.     fpat_1.sig2 = tmp4;
  1311. /*<       CLT= TMP5 >*/
  1312.     fpat_1.clt = tmp5;
  1313. /*<       CHT= TMP6 >*/
  1314.     fpat_1.cht = tmp6;
  1315.  
  1316. /*     EXCITATION PARAMETERS */
  1317.  
  1318. /*<       GOTO 14 >*/
  1319.     goto L14;
  1320. /*<    24 IF( IFLOW.EQ.5) GOTO 25 >*/
  1321. L24:
  1322.     if (iflow == 5) {
  1323.     goto L25;
  1324.     }
  1325. /*<       NSANT=0 >*/
  1326.     vsorc_1.nsant = 0;
  1327. /*<       NVQD=0 >*/
  1328.     vsorc_1.nvqd = 0;
  1329. /*<       IPED=0 >*/
  1330.     iped = 0;
  1331. /*<       IFLOW=5 >*/
  1332.     iflow = 5;
  1333. /*<       IF( IGO.GT.3) IGO=3 >*/
  1334.     if (igo > 3) {
  1335.     igo = 3;
  1336.     }
  1337. /*<    25 MASYM= ITMP4/10 >*/
  1338. L25:
  1339.     netcx_1.masym = itmp4 / 10;
  1340. /*<       IF( ITMP1.GT.0.AND. ITMP1.NE.5) GOTO 27 >*/
  1341.     if (itmp1 > 0 && itmp1 != 5) {
  1342.     goto L27;
  1343.     }
  1344. /*<       IXTYP= ITMP1 >*/
  1345.     fpat_1.ixtyp = itmp1;
  1346. /*<       NTSOL=0 >*/
  1347.     netcx_1.ntsol = 0;
  1348. /*<       IF( IXTYP.EQ.0) GOTO 205 >*/
  1349.     if (fpat_1.ixtyp == 0) {
  1350.     goto L205;
  1351.     }
  1352. /*<       NVQD= NVQD+1 >*/
  1353.     ++vsorc_1.nvqd;
  1354. /*<       IF( NVQD.GT. NSMAX) GOTO 206 >*/
  1355.     if (vsorc_1.nvqd > nsmax) {
  1356.     goto L206;
  1357.     }
  1358. /*<       IVQD( NVQD)= ISEGNO( ITMP2, ITMP3) >*/
  1359.     vsorc_1.ivqd[vsorc_1.nvqd - 1] = isegno_(&itmp2, &itmp3);
  1360. /*<       VQD( NVQD)= CMPLX( TMP1, TMP2) >*/
  1361.     i__2 = vsorc_1.nvqd - 1;
  1362.     z__1.r = tmp1, z__1.i = tmp2;
  1363.     vsorc_1.vqd[i__2].r = z__1.r, vsorc_1.vqd[i__2].i = z__1.i;
  1364. /*<       IF( ABS( VQD( NVQD)).LT.1.D-20) VQD( NVQD)=(1.,0.) >*/
  1365.     if (z_abs(&vsorc_1.vqd[vsorc_1.nvqd - 1]) < 1e-20) {
  1366.     i__2 = vsorc_1.nvqd - 1;
  1367.     vsorc_1.vqd[i__2].r = 1., vsorc_1.vqd[i__2].i = 0.;
  1368.     }
  1369. /*<       GOTO 207 >*/
  1370.     goto L207;
  1371. /*<   205 NSANT= NSANT+1 >*/
  1372. L205:
  1373.     ++vsorc_1.nsant;
  1374. /*<       IF( NSANT.LE. NSMAX) GOTO 26 >*/
  1375.     if (vsorc_1.nsant <= nsmax) {
  1376.     goto L26;
  1377.     }
  1378. /*<   206 WRITE( 6,141)  >*/
  1379. L206:
  1380.     s_wsfe(&io___85);
  1381.     e_wsfe();
  1382. /*<       STOP >*/
  1383.     s_stop("", 0L);
  1384. /*<    26 ISANT( NSANT)= ISEGNO( ITMP2, ITMP3) >*/
  1385. L26:
  1386.     vsorc_1.isant[vsorc_1.nsant - 1] = isegno_(&itmp2, &itmp3);
  1387. /*<       VSANT( NSANT)= CMPLX( TMP1, TMP2) >*/
  1388.     i__2 = vsorc_1.nsant - 1;
  1389.     z__1.r = tmp1, z__1.i = tmp2;
  1390.     vsorc_1.vsant[i__2].r = z__1.r, vsorc_1.vsant[i__2].i = z__1.i;
  1391. /*<       IF( ABS( VSANT( NSANT)).LT.1.D-20) VSANT( NSANT)=(1.,0.) >*/
  1392.     if (z_abs(&vsorc_1.vsant[vsorc_1.nsant - 1]) < 1e-20) {
  1393.     i__2 = vsorc_1.nsant - 1;
  1394.     vsorc_1.vsant[i__2].r = 1., vsorc_1.vsant[i__2].i = 0.;
  1395.     }
  1396. /*<   207 IPED= ITMP4- MASYM*10 >*/
  1397. L207:
  1398.     iped = itmp4 - netcx_1.masym * 10;
  1399. /*<       ZPNORM= TMP3 >*/
  1400.     zpnorm = tmp3;
  1401. /*<       IF( IPED.EQ.1.AND. ZPNORM.GT.0) IPED=2 >*/
  1402.     if (iped == 1 && zpnorm > 0.) {
  1403.     iped = 2;
  1404.     }
  1405. /*<       GOTO 14 >*/
  1406.     goto L14;
  1407. /*<    27 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) NTSOL=0 >*/
  1408. L27:
  1409.     if (fpat_1.ixtyp == 0 || fpat_1.ixtyp == 5) {
  1410.     netcx_1.ntsol = 0;
  1411.     }
  1412. /*<       IXTYP= ITMP1 >*/
  1413.     fpat_1.ixtyp = itmp1;
  1414. /*<       NTHI= ITMP2 >*/
  1415.     nthi = itmp2;
  1416. /*<       NPHI= ITMP3 >*/
  1417.     nphi = itmp3;
  1418. /*<       XPR1= TMP1 >*/
  1419.     xpr1 = tmp1;
  1420. /*<       XPR2= TMP2 >*/
  1421.     xpr2 = tmp2;
  1422. /*<       XPR3= TMP3 >*/
  1423.     xpr3 = tmp3;
  1424. /*<       XPR4= TMP4 >*/
  1425.     xpr4 = tmp4;
  1426. /*<       XPR5= TMP5 >*/
  1427.     xpr5 = tmp5;
  1428. /*<       XPR6= TMP6 >*/
  1429.     fpat_1.xpr6 = tmp6;
  1430. /*<       NSANT=0 >*/
  1431.     vsorc_1.nsant = 0;
  1432. /*<       NVQD=0 >*/
  1433.     vsorc_1.nvqd = 0;
  1434. /*<       THETIS= XPR1 >*/
  1435.     thetis = xpr1;
  1436. /*<       PHISS= XPR2 >*/
  1437.     phiss = xpr2;
  1438.  
  1439. /*     NETWORK PARAMETERS */
  1440.  
  1441. /*<       GOTO 14 >*/
  1442.     goto L14;
  1443. /*<    28 IF( IFLOW.EQ.6) GOTO 29 >*/
  1444. L28:
  1445.     if (iflow == 6) {
  1446.     goto L29;
  1447.     }
  1448. /*<       NONET=0 >*/
  1449.     netcx_1.nonet = 0;
  1450. /*<       NTSOL=0 >*/
  1451.     netcx_1.ntsol = 0;
  1452. /*<       IFLOW=6 >*/
  1453.     iflow = 6;
  1454. /*<       IF( IGO.GT.3) IGO=3 >*/
  1455.     if (igo > 3) {
  1456.     igo = 3;
  1457.     }
  1458. /*<       IF( ITMP2.EQ.(-1)) GOTO 14 >*/
  1459.     if (itmp2 == -1) {
  1460.     goto L14;
  1461.     }
  1462. /*<    29 NONET= NONET+1 >*/
  1463. L29:
  1464.     ++netcx_1.nonet;
  1465. /*<       IF( NONET.LE. NETMX) GOTO 30 >*/
  1466.     if (netcx_1.nonet <= netmx) {
  1467.     goto L30;
  1468.     }
  1469. /*<       WRITE( 6,142)  >*/
  1470.     s_wsfe(&io___95);
  1471.     e_wsfe();
  1472. /*<       STOP >*/
  1473.     s_stop("", 0L);
  1474. /*<    30 NTYP( NONET)=2 >*/
  1475. L30:
  1476.     netcx_1.ntyp[netcx_1.nonet - 1] = 2;
  1477. /*<       IF( AIN.EQ. ATST(6)) NTYP( NONET)=1 >*/
  1478.     if (s_cmp(ain, atst + 10, 2L, 2L) == 0) {
  1479.     netcx_1.ntyp[netcx_1.nonet - 1] = 1;
  1480.     }
  1481. /*<       ISEG1( NONET)= ISEGNO( ITMP1, ITMP2) >*/
  1482.     netcx_1.iseg1[netcx_1.nonet - 1] = isegno_(&itmp1, &itmp2);
  1483. /*<       ISEG2( NONET)= ISEGNO( ITMP3, ITMP4) >*/
  1484.     netcx_1.iseg2[netcx_1.nonet - 1] = isegno_(&itmp3, &itmp4);
  1485. /*<       X11R( NONET)= TMP1 >*/
  1486.     netcx_1.x11r[netcx_1.nonet - 1] = tmp1;
  1487. /*<       X11I( NONET)= TMP2 >*/
  1488.     netcx_1.x11i[netcx_1.nonet - 1] = tmp2;
  1489. /*<       X12R( NONET)= TMP3 >*/
  1490.     netcx_1.x12r[netcx_1.nonet - 1] = tmp3;
  1491. /*<       X12I( NONET)= TMP4 >*/
  1492.     netcx_1.x12i[netcx_1.nonet - 1] = tmp4;
  1493. /*<       X22R( NONET)= TMP5 >*/
  1494.     netcx_1.x22r[netcx_1.nonet - 1] = tmp5;
  1495. /*<       X22I( NONET)= TMP6 >*/
  1496.     netcx_1.x22i[netcx_1.nonet - 1] = tmp6;
  1497. /*<       IF( NTYP( NONET).EQ.1.OR. TMP1.GT.0.) GOTO 14 >*/
  1498.     if (netcx_1.ntyp[netcx_1.nonet - 1] == 1 || tmp1 > 0.) {
  1499.     goto L14;
  1500.     }
  1501. /*<       NTYP( NONET)=3 >*/
  1502.     netcx_1.ntyp[netcx_1.nonet - 1] = 3;
  1503. /* *** */
  1504.  
  1505. /*     PLOT FLAGS */
  1506.  
  1507. /*<       X11R( NONET)=- TMP1 >*/
  1508.     netcx_1.x11r[netcx_1.nonet - 1] = -tmp1;
  1509. /*<   330 IPLP1= ITMP1 >*/
  1510. L330:
  1511.     plot_1.iplp1 = itmp1;
  1512. /*<       IPLP2= ITMP2 >*/
  1513.     plot_1.iplp2 = itmp2;
  1514. /*<       IPLP3= ITMP3 >*/
  1515.     plot_1.iplp3 = itmp3;
  1516. /* *** */
  1517. /*<       IPLP4= ITMP4 >*/
  1518.     plot_1.iplp4 = itmp4;
  1519.  
  1520. /*     PRINT CONTROL FOR CURRENT */
  1521.  
  1522. /*<       GOTO 14 >*/
  1523.     goto L14;
  1524. /*<    31 IPTFLG= ITMP1 >*/
  1525. L31:
  1526.     iptflg = itmp1;
  1527. /*<       IPTAG= ITMP2 >*/
  1528.     iptag = itmp2;
  1529. /*<       IPTAGF= ITMP3 >*/
  1530.     iptagf = itmp3;
  1531. /*<       IPTAGT= ITMP4 >*/
  1532.     iptagt = itmp4;
  1533. /*<       IF( ITMP3.EQ.0.AND. IPTFLG.NE.-1) IPTFLG=-2 >*/
  1534.     if (itmp3 == 0 && iptflg != -1) {
  1535.     iptflg = -2;
  1536.     }
  1537. /*<       IF( ITMP4.EQ.0) IPTAGT= IPTAGF >*/
  1538.     if (itmp4 == 0) {
  1539.     iptagt = iptagf;
  1540.     }
  1541.  
  1542. /*     WRITE CONTROL FOR CHARGE */
  1543.  
  1544. /*<       GOTO 14 >*/
  1545.     goto L14;
  1546. /*<   319 IPTFLQ= ITMP1 >*/
  1547. L319:
  1548.     iptflq = itmp1;
  1549. /*<       IPTAQ= ITMP2 >*/
  1550.     iptaq = itmp2;
  1551. /*<       IPTAQF= ITMP3 >*/
  1552.     iptaqf = itmp3;
  1553. /*<       IPTAQT= ITMP4 >*/
  1554.     iptaqt = itmp4;
  1555. /*<       IF( ITMP3.EQ.0.AND. IPTFLQ.NE.-1) IPTFLQ=-2 >*/
  1556.     if (itmp3 == 0 && iptflq != -1) {
  1557.     iptflq = -2;
  1558.     }
  1559. /*<       IF( ITMP4.EQ.0) IPTAQT= IPTAQF >*/
  1560.     if (itmp4 == 0) {
  1561.     iptaqt = iptaqf;
  1562.     }
  1563.  
  1564. /*     NEAR FIELD CALCULATION PARAMETERS */
  1565.  
  1566. /*<       GOTO 14 >*/
  1567.     goto L14;
  1568. /*<   208 NFEH=1 >*/
  1569. L208:
  1570.     fpat_1.nfeh = 1;
  1571. /*<       GOTO 209 >*/
  1572.     goto L209;
  1573. /*<    32 NFEH=0 >*/
  1574. L32:
  1575.     fpat_1.nfeh = 0;
  1576. /*<   209 IF(.NOT.( IFLOW.EQ.8.AND. NFRQ.NE.1)) GOTO 33 >*/
  1577. L209:
  1578.     if (! (iflow == 8 && nfrq != 1)) {
  1579.     goto L33;
  1580.     }
  1581. /*<       WRITE( 6,143)  >*/
  1582.     s_wsfe(&io___102);
  1583.     e_wsfe();
  1584. /*<    33 NEAR= ITMP1 >*/
  1585. L33:
  1586.     fpat_1.near = itmp1;
  1587. /*<       NRX= ITMP2 >*/
  1588.     fpat_1.nrx = itmp2;
  1589. /*<       NRY= ITMP3 >*/
  1590.     fpat_1.nry = itmp3;
  1591. /*<       NRZ= ITMP4 >*/
  1592.     fpat_1.nrz = itmp4;
  1593. /*<       XNR= TMP1 >*/
  1594.     fpat_1.xnr = tmp1;
  1595. /*<       YNR= TMP2 >*/
  1596.     fpat_1.ynr = tmp2;
  1597. /*<       ZNR= TMP3 >*/
  1598.     fpat_1.znr = tmp3;
  1599. /*<       DXNR= TMP4 >*/
  1600.     fpat_1.dxnr = tmp4;
  1601. /*<       DYNR= TMP5 >*/
  1602.     fpat_1.dynr = tmp5;
  1603. /*<       DZNR= TMP6 >*/
  1604.     fpat_1.dznr = tmp6;
  1605. /*<       IFLOW=8 >*/
  1606.     iflow = 8;
  1607. /*<       IF( NFRQ.NE.1) GOTO 14 >*/
  1608.     if (nfrq != 1) {
  1609.     goto L14;
  1610.     }
  1611.  
  1612. /*     GROUND REPRESENTATION */
  1613.  
  1614. /*<       GOTO (41,46,53,71,72), IGO >*/
  1615.     switch ((int)igo) {
  1616.     case 1:  goto L41;
  1617.     case 2:  goto L46;
  1618.     case 3:  goto L53;
  1619.     case 4:  goto L71;
  1620.     case 5:  goto L72;
  1621.     }
  1622. /*<    34 EPSR2= TMP1 >*/
  1623. L34:
  1624.     fpat_1.epsr2 = tmp1;
  1625. /*<       SIG2= TMP2 >*/
  1626.     fpat_1.sig2 = tmp2;
  1627. /*<       CLT= TMP3 >*/
  1628.     fpat_1.clt = tmp3;
  1629. /*<       CHT= TMP4 >*/
  1630.     fpat_1.cht = tmp4;
  1631. /*<       IFLOW=9 >*/
  1632.     iflow = 9;
  1633.  
  1634. /*     STANDARD OBSERVATION ANGLE PARAMETERS */
  1635.  
  1636. /*<       GOTO 14 >*/
  1637.     goto L14;
  1638. /*<    36 IFAR= ITMP1 >*/
  1639. L36:
  1640.     gnd_1.ifar = itmp1;
  1641. /*<       NTH= ITMP2 >*/
  1642.     fpat_1.nth = itmp2;
  1643. /*<       NPH= ITMP3 >*/
  1644.     fpat_1.nph = itmp3;
  1645. /*<       IF( NTH.EQ.0) NTH=1 >*/
  1646.     if (fpat_1.nth == 0) {
  1647.     fpat_1.nth = 1;
  1648.     }
  1649. /*<       IF( NPH.EQ.0) NPH=1 >*/
  1650.     if (fpat_1.nph == 0) {
  1651.     fpat_1.nph = 1;
  1652.     }
  1653. /*<       IPD= ITMP4/10 >*/
  1654.     fpat_1.ipd = itmp4 / 10;
  1655. /*<       IAVP= ITMP4- IPD*10 >*/
  1656.     fpat_1.iavp = itmp4 - fpat_1.ipd * 10;
  1657. /*<       INOR= IPD/10 >*/
  1658.     fpat_1.inor = fpat_1.ipd / 10;
  1659. /*<       IPD= IPD- INOR*10 >*/
  1660.     fpat_1.ipd -= fpat_1.inor * 10;
  1661. /*<       IAX= INOR/10 >*/
  1662.     fpat_1.iax = fpat_1.inor / 10;
  1663. /*<       INOR= INOR- IAX*10 >*/
  1664.     fpat_1.inor -= fpat_1.iax * 10;
  1665. /*<       IF( IAX.NE.0) IAX=1 >*/
  1666.     if (fpat_1.iax != 0) {
  1667.     fpat_1.iax = 1;
  1668.     }
  1669. /*<       IF( IPD.NE.0) IPD=1 >*/
  1670.     if (fpat_1.ipd != 0) {
  1671.     fpat_1.ipd = 1;
  1672.     }
  1673. /*<       IF( NTH.LT.2.OR. NPH.LT.2) IAVP=0 >*/
  1674.     if (fpat_1.nth < 2 || fpat_1.nph < 2) {
  1675.     fpat_1.iavp = 0;
  1676.     }
  1677. /*<       IF( IFAR.EQ.1) IAVP=0 >*/
  1678.     if (gnd_1.ifar == 1) {
  1679.     fpat_1.iavp = 0;
  1680.     }
  1681. /*<       THETS= TMP1 >*/
  1682.     fpat_1.thets = tmp1;
  1683. /*<       PHIS= TMP2 >*/
  1684.     fpat_1.phis = tmp2;
  1685. /*<       DTH= TMP3 >*/
  1686.     fpat_1.dth = tmp3;
  1687. /*<       DPH= TMP4 >*/
  1688.     fpat_1.dph = tmp4;
  1689. /*<       RFLD= TMP5 >*/
  1690.     fpat_1.rfld = tmp5;
  1691. /*<       GNOR= TMP6 >*/
  1692.     fpat_1.gnor = tmp6;
  1693. /*<       IFLOW=10 >*/
  1694.     iflow = 10;
  1695.  
  1696. /*     WRITE NUMERICAL GREEN'S FUNCTION TAPE */
  1697.  
  1698. /*<       GOTO (41,46,53,71,78), IGO >*/
  1699.     switch ((int)igo) {
  1700.     case 1:  goto L41;
  1701.     case 2:  goto L46;
  1702.     case 3:  goto L53;
  1703.     case 4:  goto L71;
  1704.     case 5:  goto L78;
  1705.     }
  1706. /*<   322 IFLOW=12 >*/
  1707. L322:
  1708.     iflow = 12;
  1709. /*<       IF( ICASX.EQ.0) GOTO 301 >*/
  1710.     if (matpar_1.icasx == 0) {
  1711.     goto L301;
  1712.     }
  1713. /*<       WRITE( 6,302)  >*/
  1714.     s_wsfe(&io___103);
  1715.     e_wsfe();
  1716. /*<       STOP >*/
  1717.     s_stop("", 0L);
  1718. /*<   301 IRNGF= IRESRV/2 >*/
  1719. L301:
  1720.     irngf = iresrv / 2;
  1721.  
  1722. /*     EXECUTE CARD  -  CALC. INCLUDING RADIATED FIELDS */
  1723.  
  1724. /*<       GOTO (41,46,52,52,52), IGO >*/
  1725.     switch ((int)igo) {
  1726.     case 1:  goto L41;
  1727.     case 2:  goto L46;
  1728.     case 3:  goto L52;
  1729.     case 4:  goto L52;
  1730.     case 5:  goto L52;
  1731.     }
  1732. /*<    37 IF( IFLOW.EQ.10.AND. ITMP1.EQ.0) GOTO 14 >*/
  1733. L37:
  1734.     if (iflow == 10 && itmp1 == 0) {
  1735.     goto L14;
  1736.     }
  1737. /*<       IF( NFRQ.EQ.1.AND. ITMP1.EQ.0.AND. IFLOW.GT.7) GOTO 14 >*/
  1738.     if (nfrq == 1 && itmp1 == 0 && iflow > 7) {
  1739.     goto L14;
  1740.     }
  1741. /*<       IF( ITMP1.NE.0) GOTO 39 >*/
  1742.     if (itmp1 != 0) {
  1743.     goto L39;
  1744.     }
  1745. /*<       IF( IFLOW.GT.7) GOTO 38 >*/
  1746.     if (iflow > 7) {
  1747.     goto L38;
  1748.     }
  1749. /*<       IFLOW=7 >*/
  1750.     iflow = 7;
  1751. /*<       GOTO 40 >*/
  1752.     goto L40;
  1753. /*<    38 IFLOW=11 >*/
  1754. L38:
  1755.     iflow = 11;
  1756. /*<       GOTO 40 >*/
  1757.     goto L40;
  1758. /*<    39 IFAR=0 >*/
  1759. L39:
  1760.     gnd_1.ifar = 0;
  1761. /*<       RFLD=0. >*/
  1762.     fpat_1.rfld = 0.;
  1763. /*<       IPD=0 >*/
  1764.     fpat_1.ipd = 0;
  1765. /*<       IAVP=0 >*/
  1766.     fpat_1.iavp = 0;
  1767. /*<       INOR=0 >*/
  1768.     fpat_1.inor = 0;
  1769. /*<       IAX=0 >*/
  1770.     fpat_1.iax = 0;
  1771. /*<       NTH=91 >*/
  1772.     fpat_1.nth = 91;
  1773. /*<       NPH=1 >*/
  1774.     fpat_1.nph = 1;
  1775. /*<       THETS=0. >*/
  1776.     fpat_1.thets = 0.;
  1777. /*<       PHIS=0. >*/
  1778.     fpat_1.phis = 0.;
  1779. /*<       DTH=1.0 >*/
  1780.     fpat_1.dth = 1.;
  1781. /*<       DPH=0. >*/
  1782.     fpat_1.dph = 0.;
  1783. /*<       IF( ITMP1.EQ.2) PHIS=90. >*/
  1784.     if (itmp1 == 2) {
  1785.     fpat_1.phis = 90.;
  1786.     }
  1787. /*<       IF( ITMP1.NE.3) GOTO 40 >*/
  1788.     if (itmp1 != 3) {
  1789.     goto L40;
  1790.     }
  1791. /*<       NPH=2 >*/
  1792.     fpat_1.nph = 2;
  1793. /*<       DPH=90. >*/
  1794.     fpat_1.dph = 90.;
  1795.  
  1796. /*     END OF THE MAIN INPUT SECTION */
  1797.  
  1798. /*     BEGINNING OF THE FREQUENCY DO LOOP */
  1799.  
  1800. /*<    40 GOTO (41,46,53,71,78), IGO >*/
  1801. L40:
  1802.     switch ((int)igo) {
  1803.     case 1:  goto L41;
  1804.     case 2:  goto L46;
  1805.     case 3:  goto L53;
  1806.     case 4:  goto L71;
  1807.     case 5:  goto L78;
  1808.     }
  1809. /* *** */
  1810. /*<    41 MHZ=1 >*/
  1811. L41:
  1812.     mhz = 1;
  1813. /*<       IF( N.EQ.0.OR. IFRTMW.EQ.1) GOTO 406 >*/
  1814.     if (data_1.n == 0 || ifrtmw == 1) {
  1815.     goto L406;
  1816.     }
  1817. /*<       IFRTMW=1 >*/
  1818.     ifrtmw = 1;
  1819. /*<       DO 445  I=1, N >*/
  1820.     i__2 = data_1.n;
  1821.     for (i = 1; i <= i__2; ++i) {
  1822. /*<       XTEMP( I)= X( I) >*/
  1823.     xtemp[i - 1] = data_1.x[i - 1];
  1824. /*<       YTEMP( I)= Y( I) >*/
  1825.     ytemp[i - 1] = data_1.y[i - 1];
  1826. /*<       ZTEMP( I)= Z( I) >*/
  1827.     ztemp[i - 1] = data_1.z[i - 1];
  1828. /*<       SITEMP( I)= SI( I) >*/
  1829.     sitemp[i - 1] = data_1.si[i - 1];
  1830. /*<       BITEMP( I)= BI( I) >*/
  1831.     bitemp[i - 1] = data_1.bi[i - 1];
  1832. /*<   445 CONTINUE >*/
  1833. /* L445: */
  1834.     }
  1835. /*<   406 IF( M.EQ.0.OR. IFRTMP.EQ.1) GOTO 407 >*/
  1836. L406:
  1837.     if (data_1.m == 0 || ifrtmp == 1) {
  1838.     goto L407;
  1839.     }
  1840. /*<       IFRTMP=1 >*/
  1841.     ifrtmp = 1;
  1842. /*<       J= LD+1 >*/
  1843.     j = data_1.ld + 1;
  1844. /*<       DO 545  I=1, M >*/
  1845.     i__2 = data_1.m;
  1846.     for (i = 1; i <= i__2; ++i) {
  1847. /*<       J= J-1 >*/
  1848.     --j;
  1849. /*<       XTEMP( J)= X( J) >*/
  1850.     xtemp[j - 1] = data_1.x[j - 1];
  1851. /*<       YTEMP( J)= Y( J) >*/
  1852.     ytemp[j - 1] = data_1.y[j - 1];
  1853. /*<       ZTEMP( J)= Z( J) >*/
  1854.     ztemp[j - 1] = data_1.z[j - 1];
  1855. /*<       BITEMP( J)= BI( J) >*/
  1856.     bitemp[j - 1] = data_1.bi[j - 1];
  1857. /*<   545 CONTINUE >*/
  1858. /* L545: */
  1859.     }
  1860. /*<   407 CONTINUE >*/
  1861. L407:
  1862. /* *** */
  1863. /*     CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX.  (A) */
  1864. /*<       FMHZ1= FMHZ >*/
  1865.     fmhz1 = save_1.fmhz;
  1866. /*<       IF( IMAT.EQ.0) CALL FBLOCK( NPEQ, NEQ, IRESRV, IRNGF, IPSYM) >*/
  1867.     if (matpar_1.imat == 0) {
  1868.     fblock_(&netcx_1.npeq, &netcx_1.neq, &iresrv, &irngf, &data_1.ipsym);
  1869.     }
  1870. /*<    42 IF( MHZ.EQ.1) GOTO 44 >*/
  1871. L42:
  1872.     if (mhz == 1) {
  1873.     goto L44;
  1874.     }
  1875. /*      FMHZ=FMHZ+DELFRQ */
  1876. /* *** */
  1877. /*<       IF( IFRQ.EQ.1) GOTO 43 >*/
  1878.     if (ifrq == 1) {
  1879.     goto L43;
  1880.     }
  1881. /*<       FMHZ= FMHZ1+( MHZ-1)* DELFRQ >*/
  1882.     save_1.fmhz = fmhz1 + (mhz - 1) * delfrq;
  1883. /*<       GOTO 44 >*/
  1884.     goto L44;
  1885. /*<    43 FMHZ= FMHZ* DELFRQ >*/
  1886. L43:
  1887.     save_1.fmhz *= delfrq;
  1888. /* *** */
  1889. /*<    44 FR= FMHZ/ CVEL >*/
  1890. L44:
  1891.     fr = save_1.fmhz / cvel;
  1892. /*<       WLAM= CVEL/ FMHZ >*/
  1893.     data_1.wlam = cvel / save_1.fmhz;
  1894. /*<       WRITE( 6,145)  FMHZ, WLAM >*/
  1895.     s_wsfe(&io___113);
  1896.     do_fio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
  1897.     do_fio(&c__1, (char *)&data_1.wlam, (ftnlen)sizeof(doublereal));
  1898.     e_wsfe();
  1899. /*<       WRITE( 6,196)  RKH >*/
  1900.     s_wsfe(&io___114);
  1901.     do_fio(&c__1, (char *)&rkh, (ftnlen)sizeof(doublereal));
  1902.     e_wsfe();
  1903. /*     FREQUENCY SCALING OF GEOMETRIC PARAMETERS */
  1904. /* ***      FMHZS=FMHZ */
  1905. /*<       IF( IEXK.EQ.1) WRITE( 6,321)  >*/
  1906.     if (iexk == 1) {
  1907.     s_wsfe(&io___115);
  1908.     e_wsfe();
  1909.     }
  1910. /*<       IF( N.EQ.0) GOTO 306 >*/
  1911.     if (data_1.n == 0) {
  1912.     goto L306;
  1913.     }
  1914. /* *** */
  1915. /*<       DO 45  I=1, N >*/
  1916.     i__2 = data_1.n;
  1917.     for (i = 1; i <= i__2; ++i) {
  1918. /*<       X( I)= XTEMP( I)* FR >*/
  1919.     data_1.x[i - 1] = xtemp[i - 1] * fr;
  1920. /*<       Y( I)= YTEMP( I)* FR >*/
  1921.     data_1.y[i - 1] = ytemp[i - 1] * fr;
  1922. /*<       Z( I)= ZTEMP( I)* FR >*/
  1923.     data_1.z[i - 1] = ztemp[i - 1] * fr;
  1924. /*<       SI( I)= SITEMP( I)* FR >*/
  1925.     data_1.si[i - 1] = sitemp[i - 1] * fr;
  1926. /* *** */
  1927. /*<    45 BI( I)= BITEMP( I)* FR >*/
  1928. /* L45: */
  1929.     data_1.bi[i - 1] = bitemp[i - 1] * fr;
  1930.     }
  1931. /*<   306 IF( M.EQ.0) GOTO 307 >*/
  1932. L306:
  1933.     if (data_1.m == 0) {
  1934.     goto L307;
  1935.     }
  1936. /*<       FR2= FR* FR >*/
  1937.     fr2 = fr * fr;
  1938. /*<       J= LD+1 >*/
  1939.     j = data_1.ld + 1;
  1940. /*<       DO 245  I=1, M >*/
  1941.     i__2 = data_1.m;
  1942.     for (i = 1; i <= i__2; ++i) {
  1943. /* *** */
  1944. /*<       J= J-1 >*/
  1945.     --j;
  1946. /*<       X( J)= XTEMP( J)* FR >*/
  1947.     data_1.x[j - 1] = xtemp[j - 1] * fr;
  1948. /*<       Y( J)= YTEMP( J)* FR >*/
  1949.     data_1.y[j - 1] = ytemp[j - 1] * fr;
  1950. /*<       Z( J)= ZTEMP( J)* FR >*/
  1951.     data_1.z[j - 1] = ztemp[j - 1] * fr;
  1952. /* *** */
  1953. /*<   245 BI( J)= BITEMP( J)* FR2 >*/
  1954. /* L245: */
  1955.     data_1.bi[j - 1] = bitemp[j - 1] * fr2;
  1956.     }
  1957. /*     STRUCTURE SEGMENT LOADING */
  1958. /*<   307 IGO=2 >*/
  1959. L307:
  1960.     igo = 2;
  1961. /*<    46 WRITE( 6,146)  >*/
  1962. L46:
  1963.     s_wsfe(&io___117);
  1964.     e_wsfe();
  1965. /*<    >*/
  1966.     if (zload_1.nload != 0) {
  1967.     load_(ldtyp, ldtag, ldtagf, ldtagt, zlr, zli, zlc);
  1968.     }
  1969. /*<       IF( NLOAD.EQ.0.AND. NLODF.EQ.0) WRITE( 6,147)  >*/
  1970.     if (zload_1.nload == 0 && zload_1.nlodf == 0) {
  1971.     s_wsfe(&io___118);
  1972.     e_wsfe();
  1973.     }
  1974. /*     GROUND PARAMETER */
  1975. /*<       IF( NLOAD.EQ.0.AND. NLODF.NE.0) WRITE( 6,327)  >*/
  1976.     if (zload_1.nload == 0 && zload_1.nlodf != 0) {
  1977.     s_wsfe(&io___119);
  1978.     e_wsfe();
  1979.     }
  1980. /*<       WRITE( 6,148)  >*/
  1981.     s_wsfe(&io___120);
  1982.     e_wsfe();
  1983. /*<       IF( KSYMP.EQ.1) GOTO 49 >*/
  1984.     if (gnd_1.ksymp == 1) {
  1985.     goto L49;
  1986.     }
  1987. /*<       FRATI=(1.,0.) >*/
  1988.     gnd_1.frati.r = 1., gnd_1.frati.i = 0.;
  1989. /*<       IF( IPERF.EQ.1) GOTO 48 >*/
  1990.     if (gnd_1.iperf == 1) {
  1991.     goto L48;
  1992.     }
  1993. /*<       IF( SIG.LT.0.) SIG=- SIG/(59.96* WLAM) >*/
  1994.     if (save_1.sig < 0.) {
  1995.     save_1.sig = -save_1.sig / (data_1.wlam * 59.96);
  1996.     }
  1997. /*<       EPSC= CMPLX( EPSR,- SIG* WLAM*59.96) >*/
  1998.     d__2 = -save_1.sig * data_1.wlam;
  1999.     d__1 = d__2 * 59.96;
  2000.     z__1.r = save_1.epsr, z__1.i = d__1;
  2001.     epsc.r = z__1.r, epsc.i = z__1.i;
  2002. /*<       ZRATI=1./ SQRT( EPSC) >*/
  2003.     z_sqrt(&z__2, &epsc);
  2004.     z_div(&z__1, &c_b48, &z__2);
  2005.     gnd_1.zrati.r = z__1.r, gnd_1.zrati.i = z__1.i;
  2006. /*<       U= ZRATI >*/
  2007.     gwav_1.u.r = gnd_1.zrati.r, gwav_1.u.i = gnd_1.zrati.i;
  2008. /*<       U2= U* U >*/
  2009.     z__1.r = gwav_1.u.r * gwav_1.u.r - gwav_1.u.i * gwav_1.u.i, z__1.i = 
  2010.         gwav_1.u.r * gwav_1.u.i + gwav_1.u.i * gwav_1.u.r;
  2011.     gwav_1.u2.r = z__1.r, gwav_1.u2.i = z__1.i;
  2012. /*<       IF( NRADL.EQ.0) GOTO 47 >*/
  2013.     if (gnd_1.nradl == 0) {
  2014.     goto L47;
  2015.     }
  2016. /*<       SCRWL= SCRWLT/ WLAM >*/
  2017.     gnd_1.scrwl = save_1.scrwlt / data_1.wlam;
  2018. /*<       SCRWR= SCRWRT/ WLAM >*/
  2019.     gnd_1.scrwr = save_1.scrwrt / data_1.wlam;
  2020. /*<       T1= FJ*2367.067D+0/ DFLOAT( NRADL) >*/
  2021.     z__2.r = fj.r * 2367.067, z__2.i = fj.i * 2367.067;
  2022.     d__1 = (doublereal) gnd_1.nradl;
  2023.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  2024.     gnd_1.t1.r = z__1.r, gnd_1.t1.i = z__1.i;
  2025. /*<       T2= SCRWR* DFLOAT( NRADL) >*/
  2026.     gnd_1.t2 = gnd_1.scrwr * (doublereal) gnd_1.nradl;
  2027. /*<       WRITE( 6,170)  NRADL, SCRWLT, SCRWRT >*/
  2028.     s_wsfe(&io___122);
  2029.     do_fio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
  2030.     do_fio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
  2031.     do_fio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
  2032.     e_wsfe();
  2033. /*<       WRITE( 6,149)  >*/
  2034.     s_wsfe(&io___123);
  2035.     e_wsfe();
  2036. /*<    47 IF( IPERF.EQ.2) GOTO 328 >*/
  2037. L47:
  2038.     if (gnd_1.iperf == 2) {
  2039.     goto L328;
  2040.     }
  2041. /*<       WRITE( 6,391)  >*/
  2042.     s_wsfe(&io___124);
  2043.     e_wsfe();
  2044. /*<       GOTO 329 >*/
  2045.     goto L329;
  2046. /*<    >*/
  2047. L328:
  2048.     if (ggrid_1.nxa[0] == 0) {
  2049.     s_rsue(&io___125);
  2050.     do_uio(&c__880, (char *)&ggrid_1.ar1[0], (ftnlen)sizeof(doublereal));
  2051.     do_uio(&c__680, (char *)&ggrid_1.ar2[0], (ftnlen)sizeof(doublereal));
  2052.     do_uio(&c__576, (char *)&ggrid_1.ar3[0], (ftnlen)sizeof(doublereal));
  2053.     do_uio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
  2054.     do_uio(&c__3, (char *)&ggrid_1.dxa[0], (ftnlen)sizeof(doublereal));
  2055.     do_uio(&c__3, (char *)&ggrid_1.dya[0], (ftnlen)sizeof(doublereal));
  2056.     do_uio(&c__3, (char *)&ggrid_1.xsa[0], (ftnlen)sizeof(doublereal));
  2057.     do_uio(&c__3, (char *)&ggrid_1.ysa[0], (ftnlen)sizeof(doublereal));
  2058.     do_uio(&c__3, (char *)&ggrid_1.nxa[0], (ftnlen)sizeof(integer));
  2059.     do_uio(&c__3, (char *)&ggrid_1.nya[0], (ftnlen)sizeof(integer));
  2060.     e_rsue();
  2061.     }
  2062. /*<       FRATI=( EPSC-1.)/( EPSC+1.) >*/
  2063.     z__2.r = epsc.r - 1., z__2.i = epsc.i;
  2064.     z__3.r = epsc.r + 1., z__3.i = epsc.i;
  2065.     z_div(&z__1, &z__2, &z__3);
  2066.     gnd_1.frati.r = z__1.r, gnd_1.frati.i = z__1.i;
  2067. /*<       IF( ABS(( EPSCF- EPSC)/ EPSC).LT.1.D-3) GOTO 400 >*/
  2068.     z__2.r = ggrid_1.epscf.r - epsc.r, z__2.i = ggrid_1.epscf.i - epsc.i;
  2069.     z_div(&z__1, &z__2, &epsc);
  2070.     if (z_abs(&z__1) < .001) {
  2071.     goto L400;
  2072.     }
  2073. /*<       WRITE( 6,393)  EPSCF, EPSC >*/
  2074.     s_wsfe(&io___126);
  2075.     do_fio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
  2076.     do_fio(&c__2, (char *)&epsc, (ftnlen)sizeof(doublereal));
  2077.     e_wsfe();
  2078. /*<       STOP >*/
  2079.     s_stop("", 0L);
  2080. /*<   400 WRITE( 6,392)  >*/
  2081. L400:
  2082.     s_wsfe(&io___127);
  2083.     e_wsfe();
  2084. /*<   329 WRITE( 6,150)  EPSR, SIG, EPSC >*/
  2085. L329:
  2086.     s_wsfe(&io___128);
  2087.     do_fio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
  2088.     do_fio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
  2089.     do_fio(&c__2, (char *)&epsc, (ftnlen)sizeof(doublereal));
  2090.     e_wsfe();
  2091. /*<       GOTO 50 >*/
  2092.     goto L50;
  2093. /*<    48 WRITE( 6,151)  >*/
  2094. L48:
  2095.     s_wsfe(&io___129);
  2096.     e_wsfe();
  2097. /*<       GOTO 50 >*/
  2098.     goto L50;
  2099. /*<    49 WRITE( 6,152)  >*/
  2100. L49:
  2101.     s_wsfe(&io___130);
  2102.     e_wsfe();
  2103. /* * * * */
  2104. /*     FILL AND FACTOR PRIMARY INTERACTION MATRIX */
  2105.  
  2106. /*<    50 CONTINUE >*/
  2107. L50:
  2108. /*<       CALL SECNDS( TIM1) >*/
  2109.     secnds_(&tim1);
  2110. /*<       IF( ICASX.NE.0) GOTO 324 >*/
  2111.     if (matpar_1.icasx != 0) {
  2112.     goto L324;
  2113.     }
  2114. /*<       CALL CMSET( NEQ, CM, RKH, IEXK) >*/
  2115.     cmset_(&netcx_1.neq, cmb_1.cm, &rkh, &iexk);
  2116. /*<       CALL SECNDS( TIM2) >*/
  2117.     secnds_(&tim2);
  2118. /*<       TIM= TIM2- TIM1 >*/
  2119.     tim = tim2 - tim1;
  2120. /*<       CALL FACTRS( NPEQ, NEQ, CM, IP, IX,11,12,13,14) >*/
  2121.     factrs_(&netcx_1.npeq, &netcx_1.neq, cmb_1.cm, save_1.ip, ix, &c__11, &
  2122.         c__12, &c__13, &c__14);
  2123.  
  2124. /*     N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B) */
  2125.  
  2126. /* **** */
  2127. /*<       GOTO 323 >*/
  2128.     goto L323;
  2129. /* **** */
  2130. /*<   324 IF( NEQ2.EQ.0) GOTO 333 >*/
  2131. L324:
  2132.     if (netcx_1.neq2 == 0) {
  2133.     goto L333;
  2134.     }
  2135. /*<    >*/
  2136.     cmngf_(&cmb_1.cm[ib11 - 1], &cmb_1.cm[ic11 - 1], &cmb_1.cm[id11 - 1], &
  2137.         matpar_1.npbx, &netcx_1.neq, &netcx_1.neq2, &rkh, &iexk);
  2138. /*<       CALL SECNDS( TIM2) >*/
  2139.     secnds_(&tim2);
  2140. /*<       TIM= TIM2- TIM1 >*/
  2141.     tim = tim2 - tim1;
  2142. /*<    >*/
  2143.     facgf_(cmb_1.cm, &cmb_1.cm[ib11 - 1], &cmb_1.cm[ic11 - 1], &cmb_1.cm[id11 
  2144.         - 1], &cmb_1.cm[ix11 - 1], save_1.ip, ix, &data_1.np, &data_1.n1, 
  2145.         &data_1.mp, &data_1.m1, &netcx_1.neq, &netcx_1.neq2);
  2146. /*<   323 CALL SECNDS( TIM1) >*/
  2147. L323:
  2148.     secnds_(&tim1);
  2149. /*<       TIM2= TIM1- TIM2 >*/
  2150.     tim2 = tim1 - tim2;
  2151. /*<       WRITE( 6,153)  TIM, TIM2 >*/
  2152.     s_wsfe(&io___135);
  2153.     do_fio(&c__1, (char *)&tim, (ftnlen)sizeof(doublereal));
  2154.     do_fio(&c__1, (char *)&tim2, (ftnlen)sizeof(doublereal));
  2155.     e_wsfe();
  2156. /*<   333 IGO=3 >*/
  2157. L333:
  2158.     igo = 3;
  2159. /*<       NTSOL=0 >*/
  2160.     netcx_1.ntsol = 0;
  2161. /*     WRITE N.G.F. FILE */
  2162. /*<       IF( IFLOW.NE.12) GOTO 53 >*/
  2163.     if (iflow != 12) {
  2164.     goto L53;
  2165.     }
  2166. /*<    52 CALL GFOUT >*/
  2167. L52:
  2168.     gfout_();
  2169.  
  2170. /*     EXCITATION SET UP (RIGHT HAND SIDE, -E INC.) */
  2171.  
  2172. /*<       GOTO 14 >*/
  2173.     goto L14;
  2174. /*<    53 NTHIC=1 >*/
  2175. L53:
  2176.     nthic = 1;
  2177. /*<       NPHIC=1 >*/
  2178.     nphic = 1;
  2179. /*<       INC=1 >*/
  2180.     inc = 1;
  2181. /*<       NPRINT=0 >*/
  2182.     netcx_1.nprint = 0;
  2183. /*<    54 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 56 >*/
  2184. L54:
  2185.     if (fpat_1.ixtyp == 0 || fpat_1.ixtyp == 5) {
  2186.     goto L56;
  2187.     }
  2188. /*<       IF( IPTFLG.LE.0.OR. IXTYP.EQ.4) WRITE( 6,154)  >*/
  2189.     if (iptflg <= 0 || fpat_1.ixtyp == 4) {
  2190.     s_wsfe(&io___139);
  2191.     e_wsfe();
  2192.     }
  2193. /*<       TMP5= TA* XPR5 >*/
  2194.     tmp5 = ta * xpr5;
  2195. /*<       TMP4= TA* XPR4 >*/
  2196.     tmp4 = ta * xpr4;
  2197. /*<       IF( IXTYP.NE.4) GOTO 55 >*/
  2198.     if (fpat_1.ixtyp != 4) {
  2199.     goto L55;
  2200.     }
  2201. /*<       TMP1= XPR1/ WLAM >*/
  2202.     tmp1 = xpr1 / data_1.wlam;
  2203. /*<       TMP2= XPR2/ WLAM >*/
  2204.     tmp2 = xpr2 / data_1.wlam;
  2205. /*<       TMP3= XPR3/ WLAM >*/
  2206.     tmp3 = xpr3 / data_1.wlam;
  2207. /*<       TMP6= XPR6/( WLAM* WLAM) >*/
  2208.     tmp6 = fpat_1.xpr6 / (data_1.wlam * data_1.wlam);
  2209. /*<       WRITE( 6,156)  XPR1, XPR2, XPR3, XPR4, XPR5, XPR6 >*/
  2210.     s_wsfe(&io___140);
  2211.     do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
  2212.     do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
  2213.     do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
  2214.     do_fio(&c__1, (char *)&xpr4, (ftnlen)sizeof(doublereal));
  2215.     do_fio(&c__1, (char *)&xpr5, (ftnlen)sizeof(doublereal));
  2216.     do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
  2217.     e_wsfe();
  2218. /*<       GOTO 56 >*/
  2219.     goto L56;
  2220. /*<    55 TMP1= TA* XPR1 >*/
  2221. L55:
  2222.     tmp1 = ta * xpr1;
  2223. /*<       TMP2= TA* XPR2 >*/
  2224.     tmp2 = ta * xpr2;
  2225. /*<       TMP3= TA* XPR3 >*/
  2226.     tmp3 = ta * xpr3;
  2227. /*<       TMP6= XPR6 >*/
  2228.     tmp6 = fpat_1.xpr6;
  2229. /*<    >*/
  2230.     if (iptflg <= 0) {
  2231.     s_wsfe(&io___141);
  2232.     do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
  2233.     do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
  2234.     do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
  2235.     do_fio(&c__1, hpol + (fpat_1.ixtyp - 1) * 6, 6L);
  2236.     do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
  2237.     e_wsfe();
  2238.     }
  2239.  
  2240. /*     MATRIX SOLVING  (NETWK CALLS SOLVES) */
  2241.  
  2242. /*<    56 CALL ETMNS( TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, IXTYP, CUR) >*/
  2243. L56:
  2244.     etmns_(&tmp1, &tmp2, &tmp3, &tmp4, &tmp5, &tmp6, &fpat_1.ixtyp, 
  2245.         crnt_1.cur);
  2246. /*<       IF( NONET.EQ.0.OR. INC.GT.1) GOTO 60 >*/
  2247.     if (netcx_1.nonet == 0 || inc > 1) {
  2248.     goto L60;
  2249.     }
  2250. /*<       WRITE( 6,158)  >*/
  2251.     s_wsfe(&io___142);
  2252.     e_wsfe();
  2253. /*<       ITMP3=0 >*/
  2254.     itmp3 = 0;
  2255. /*<       ITMP1= NTYP(1) >*/
  2256.     itmp1 = netcx_1.ntyp[0];
  2257. /*<       DO 59  I=1,2 >*/
  2258.     for (i = 1; i <= 2; ++i) {
  2259. /*<       IF( ITMP1.EQ.3) ITMP1=2 >*/
  2260.     if (itmp1 == 3) {
  2261.         itmp1 = 2;
  2262.     }
  2263. /*<       IF( ITMP1.EQ.2) WRITE( 6,159)  >*/
  2264.     if (itmp1 == 2) {
  2265.         s_wsfe(&io___143);
  2266.         e_wsfe();
  2267.     }
  2268. /*<       IF( ITMP1.EQ.1) WRITE( 6,160)  >*/
  2269.     if (itmp1 == 1) {
  2270.         s_wsfe(&io___144);
  2271.         e_wsfe();
  2272.     }
  2273. /*<       DO 58  J=1, NONET >*/
  2274.     i__2 = netcx_1.nonet;
  2275.     for (j = 1; j <= i__2; ++j) {
  2276. /*<       ITMP2= NTYP( J) >*/
  2277.         itmp2 = netcx_1.ntyp[j - 1];
  2278. /*<       IF(( ITMP2/ ITMP1).EQ.1) GOTO 57 >*/
  2279.         if (itmp2 / itmp1 == 1) {
  2280.         goto L57;
  2281.         }
  2282. /*<       ITMP3= ITMP2 >*/
  2283.         itmp3 = itmp2;
  2284. /*<       GOTO 58 >*/
  2285.         goto L58;
  2286. /*<    57 ITMP4= ISEG1( J) >*/
  2287. L57:
  2288.         itmp4 = netcx_1.iseg1[j - 1];
  2289. /*<       ITMP5= ISEG2( J) >*/
  2290.         itmp5 = netcx_1.iseg2[j - 1];
  2291. /*<    >*/
  2292.         if (itmp2 >= 2 && netcx_1.x11i[j - 1] <= 0.) {
  2293. /* Computing 2nd power */
  2294.         d__2 = data_1.x[itmp5 - 1] - data_1.x[itmp4 - 1];
  2295. /* Computing 2nd power */
  2296.         d__3 = data_1.y[itmp5 - 1] - data_1.y[itmp4 - 1];
  2297.         d__1 = d__2 * d__2 + d__3 * d__3;
  2298. /* Computing 2nd power */
  2299.         d__4 = data_1.z[itmp5 - 1] - data_1.z[itmp4 - 1];
  2300.         netcx_1.x11i[j - 1] = data_1.wlam * sqrt(d__1 + d__4 * d__4);
  2301.         }
  2302. /*<    >*/
  2303.         s_wsfe(&io___146);
  2304.         do_fio(&c__1, (char *)&data_1.itag[itmp4 - 1], (ftnlen)sizeof(
  2305.             integer));
  2306.         do_fio(&c__1, (char *)&itmp4, (ftnlen)sizeof(integer));
  2307.         do_fio(&c__1, (char *)&data_1.itag[itmp5 - 1], (ftnlen)sizeof(
  2308.             integer));
  2309.         do_fio(&c__1, (char *)&itmp5, (ftnlen)sizeof(integer));
  2310.         do_fio(&c__1, (char *)&netcx_1.x11r[j - 1], (ftnlen)sizeof(
  2311.             doublereal));
  2312.         do_fio(&c__1, (char *)&netcx_1.x11i[j - 1], (ftnlen)sizeof(
  2313.             doublereal));
  2314.         do_fio(&c__1, (char *)&netcx_1.x12r[j - 1], (ftnlen)sizeof(
  2315.             doublereal));
  2316.         do_fio(&c__1, (char *)&netcx_1.x12i[j - 1], (ftnlen)sizeof(
  2317.             doublereal));
  2318.         do_fio(&c__1, (char *)&netcx_1.x22r[j - 1], (ftnlen)sizeof(
  2319.             doublereal));
  2320.         do_fio(&c__1, (char *)&netcx_1.x22i[j - 1], (ftnlen)sizeof(
  2321.             doublereal));
  2322.         do_fio(&c__1, pnet + ((itmp2 << 1) - 2) * 6, 6L);
  2323.         do_fio(&c__1, pnet + ((itmp2 << 1) - 1) * 6, 6L);
  2324.         e_wsfe();
  2325. /*<    58 CONTINUE >*/
  2326. L58:
  2327.         ;
  2328.     }
  2329. /*<       IF( ITMP3.EQ.0) GOTO 60 >*/
  2330.     if (itmp3 == 0) {
  2331.         goto L60;
  2332.     }
  2333. /*<       ITMP1= ITMP3 >*/
  2334.     itmp1 = itmp3;
  2335. /*<    59 CONTINUE >*/
  2336. /* L59: */
  2337.     }
  2338. /*<    60 CONTINUE >*/
  2339. L60:
  2340. /*<       IF( INC.GT.1.AND. IPTFLG.GT.0) NPRINT=1 >*/
  2341.     if (inc > 1 && iptflg > 0) {
  2342.     netcx_1.nprint = 1;
  2343.     }
  2344. /*<       CALL NETWK( CM, CM( IB11), CM( IC11), CM( ID11), IP, CUR) >*/
  2345.     netwk_(cmb_1.cm, &cmb_1.cm[ib11 - 1], &cmb_1.cm[ic11 - 1], &cmb_1.cm[id11 
  2346.         - 1], save_1.ip, crnt_1.cur);
  2347. /*<       NTSOL=1 >*/
  2348.     netcx_1.ntsol = 1;
  2349. /*<       IF( IPED.EQ.0) GOTO 61 >*/
  2350.     if (iped == 0) {
  2351.     goto L61;
  2352.     }
  2353. /*<       ITMP1= MHZ+4*( MHZ-1) >*/
  2354.     itmp1 = mhz + (mhz - 1 << 2);
  2355. /*<       IF( ITMP1.GT.( NORMF-3)) GOTO 61 >*/
  2356.     if (itmp1 > normf - 3) {
  2357.     goto L61;
  2358.     }
  2359. /*<       FNORM( ITMP1)= REAL( ZPED) >*/
  2360.     fnorm[itmp1 - 1] = netcx_1.zped.r;
  2361. /*<       FNORM( ITMP1+1)= AIMAG( ZPED) >*/
  2362.     fnorm[itmp1] = d_imag(&netcx_1.zped);
  2363. /*<       FNORM( ITMP1+2)= ABS( ZPED) >*/
  2364.     fnorm[itmp1 + 1] = z_abs(&netcx_1.zped);
  2365. /*<       FNORM( ITMP1+3)= CANG( ZPED) >*/
  2366.     fnorm[itmp1 + 2] = cang_(&netcx_1.zped);
  2367. /*<       IF( IPED.EQ.2) GOTO 61 >*/
  2368.     if (iped == 2) {
  2369.     goto L61;
  2370.     }
  2371. /*<       IF( FNORM( ITMP1+2).GT. ZPNORM) ZPNORM= FNORM( ITMP1+2) >*/
  2372.     if (fnorm[itmp1 + 1] > zpnorm) {
  2373.     zpnorm = fnorm[itmp1 + 1];
  2374.     }
  2375.  
  2376. /*     PRINTING STRUCTURE CURRENTS */
  2377.  
  2378. /*<    61 CONTINUE >*/
  2379. L61:
  2380. /*<       IF( N.EQ.0) GOTO 308 >*/
  2381.     if (data_1.n == 0) {
  2382.     goto L308;
  2383.     }
  2384. /*<       IF( IPTFLG.EQ.(-1)) GOTO 63 >*/
  2385.     if (iptflg == -1) {
  2386.     goto L63;
  2387.     }
  2388. /*<       IF( IPTFLG.GT.0) GOTO 62 >*/
  2389.     if (iptflg > 0) {
  2390.     goto L62;
  2391.     }
  2392. /*<       WRITE( 6,161)  >*/
  2393.     s_wsfe(&io___148);
  2394.     e_wsfe();
  2395. /*<       WRITE( 6,162)  >*/
  2396.     s_wsfe(&io___149);
  2397.     e_wsfe();
  2398. /*<       GOTO 63 >*/
  2399.     goto L63;
  2400. /*<    62 IF( IPTFLG.EQ.3.OR. INC.GT.1) GOTO 63 >*/
  2401. L62:
  2402.     if (iptflg == 3 || inc > 1) {
  2403.     goto L63;
  2404.     }
  2405. /*<       WRITE( 6,163)  XPR3, HPOL( IXTYP), XPR6 >*/
  2406.     s_wsfe(&io___150);
  2407.     do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
  2408.     do_fio(&c__1, hpol + (fpat_1.ixtyp - 1) * 6, 6L);
  2409.     do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
  2410.     e_wsfe();
  2411. /*<    63 PLOSS=0. >*/
  2412. L63:
  2413.     fpat_1.ploss = 0.;
  2414. /*<       ITMP1=0 >*/
  2415.     itmp1 = 0;
  2416. /*<       JUMP= IPTFLG+1 >*/
  2417.     jump = iptflg + 1;
  2418. /*<       DO 69  I=1, N >*/
  2419.     i__2 = data_1.n;
  2420.     for (i = 1; i <= i__2; ++i) {
  2421. /*<       CURI= CUR( I)* WLAM >*/
  2422.     i__1 = i - 1;
  2423.     z__1.r = data_1.wlam * crnt_1.cur[i__1].r, z__1.i = data_1.wlam * 
  2424.         crnt_1.cur[i__1].i;
  2425.     curi.r = z__1.r, curi.i = z__1.i;
  2426. /*<       CMAG= ABS( CURI) >*/
  2427.     cmag = z_abs(&curi);
  2428. /*<       PH= CANG( CURI) >*/
  2429.     ph = cang_(&curi);
  2430. /*<       IF( NLOAD.EQ.0.AND. NLODF.EQ.0) GOTO 64 >*/
  2431.     if (zload_1.nload == 0 && zload_1.nlodf == 0) {
  2432.         goto L64;
  2433.     }
  2434. /*<       IF( ABS( REAL( ZARRAY( I))).LT.1.D-20) GOTO 64 >*/
  2435.     i__1 = i - 1;
  2436.     if ((d__1 = zload_1.zarray[i__1].r, abs(d__1)) < 1e-20) {
  2437.         goto L64;
  2438.     }
  2439. /*<       PLOSS= PLOSS+.5* CMAG* CMAG* REAL( ZARRAY( I))* SI( I) >*/
  2440.     d__3 = cmag * .5;
  2441.     d__2 = d__3 * cmag;
  2442.     i__1 = i - 1;
  2443.     d__1 = d__2 * zload_1.zarray[i__1].r;
  2444.     fpat_1.ploss += d__1 * data_1.si[i - 1];
  2445. /*<    64 IF( JUMP) 68,69,65 >*/
  2446. L64:
  2447.     if (jump < 0) {
  2448.         goto L68;
  2449.     } else if (jump == 0) {
  2450.         goto L69;
  2451.     } else {
  2452.         goto L65;
  2453.     }
  2454. /*<    65 IF( IPTAG.EQ.0) GOTO 66 >*/
  2455. L65:
  2456.     if (iptag == 0) {
  2457.         goto L66;
  2458.     }
  2459. /*<       IF( ITAG( I).NE. IPTAG) GOTO 69 >*/
  2460.     if (data_1.itag[i - 1] != iptag) {
  2461.         goto L69;
  2462.     }
  2463. /*<    66 ITMP1= ITMP1+1 >*/
  2464. L66:
  2465.     ++itmp1;
  2466. /*<       IF( ITMP1.LT. IPTAGF.OR. ITMP1.GT. IPTAGT) GOTO 69 >*/
  2467.     if (itmp1 < iptagf || itmp1 > iptagt) {
  2468.         goto L69;
  2469.     }
  2470. /*<       IF( IPTFLG.EQ.0) GOTO 68 >*/
  2471.     if (iptflg == 0) {
  2472.         goto L68;
  2473.     }
  2474. /*<       IF( IPTFLG.LT.2.OR. INC.GT. NORMF) GOTO 67 >*/
  2475.     if (iptflg < 2 || inc > normf) {
  2476.         goto L67;
  2477.     }
  2478. /*<       FNORM( INC)= CMAG >*/
  2479.     fnorm[inc - 1] = cmag;
  2480. /*<       ISAVE= I >*/
  2481.     isave = i;
  2482. /*<    67 IF( IPTFLG.NE.3) WRITE( 6,164)  XPR1, XPR2, CMAG, PH, I >*/
  2483. L67:
  2484.     if (iptflg != 3) {
  2485.         s_wsfe(&io___156);
  2486.         do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
  2487.         do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
  2488.         do_fio(&c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
  2489.         do_fio(&c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
  2490.         do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  2491.         e_wsfe();
  2492.     }
  2493. /*<       GOTO 69 >*/
  2494.     goto L69;
  2495. /* *** */
  2496. /*<    >*/
  2497. L68:
  2498.     s_wsfe(&io___157);
  2499.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  2500.     do_fio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
  2501.     do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  2502.     do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  2503.     do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  2504.     do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  2505.     do_fio(&c__2, (char *)&curi, (ftnlen)sizeof(doublereal));
  2506.     do_fio(&c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
  2507.     do_fio(&c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
  2508.     e_wsfe();
  2509. /*<       IF( IPLP1.NE.1) GOTO 69 >*/
  2510.     if (plot_1.iplp1 != 1) {
  2511.         goto L69;
  2512.     }
  2513. /*<       IF( IPLP2.EQ.1) WRITE( 8,*)  CURI >*/
  2514.     if (plot_1.iplp2 == 1) {
  2515.         s_wsle(&io___158);
  2516.         do_lio(&c__7, &c__1, (char *)&curi, (ftnlen)sizeof(doublecomplex))
  2517.             ;
  2518.         e_wsle();
  2519.     }
  2520. /* *** */
  2521. /*<       IF( IPLP2.EQ.2) WRITE( 8,*)  CMAG, PH >*/
  2522.     if (plot_1.iplp2 == 2) {
  2523.         s_wsle(&io___159);
  2524.         do_lio(&c__5, &c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
  2525.         do_lio(&c__5, &c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
  2526.         e_wsle();
  2527.     }
  2528. /*<    69 CONTINUE >*/
  2529. L69:
  2530.     ;
  2531.     }
  2532. /*<       IF( IPTFLQ.EQ.(-1)) GOTO 308 >*/
  2533.     if (iptflq == -1) {
  2534.     goto L308;
  2535.     }
  2536. /*<       WRITE( 6,315)  >*/
  2537.     s_wsfe(&io___160);
  2538.     e_wsfe();
  2539. /*<       ITMP1=0 >*/
  2540.     itmp1 = 0;
  2541. /*<       FR=1.D-6/ FMHZ >*/
  2542.     fr = 1e-6 / save_1.fmhz;
  2543. /*<       DO 316  I=1, N >*/
  2544.     i__2 = data_1.n;
  2545.     for (i = 1; i <= i__2; ++i) {
  2546. /*<       IF( IPTFLQ.EQ.(-2)) GOTO 318 >*/
  2547.     if (iptflq == -2) {
  2548.         goto L318;
  2549.     }
  2550. /*<       IF( IPTAQ.EQ.0) GOTO 317 >*/
  2551.     if (iptaq == 0) {
  2552.         goto L317;
  2553.     }
  2554. /*<       IF( ITAG( I).NE. IPTAQ) GOTO 316 >*/
  2555.     if (data_1.itag[i - 1] != iptaq) {
  2556.         goto L316;
  2557.     }
  2558. /*<   317 ITMP1= ITMP1+1 >*/
  2559. L317:
  2560.     ++itmp1;
  2561. /*<       IF( ITMP1.LT. IPTAQF.OR. ITMP1.GT. IPTAQT) GOTO 316 >*/
  2562.     if (itmp1 < iptaqf || itmp1 > iptaqt) {
  2563.         goto L316;
  2564.     }
  2565. /*<   318 CURI= FR* CMPLX(- BII( I), BIR( I)) >*/
  2566. L318:
  2567.     d__1 = -crnt_1.bii[i - 1];
  2568.     i__1 = i - 1;
  2569.     z__2.r = d__1, z__2.i = crnt_1.bir[i__1];
  2570.     z__1.r = fr * z__2.r, z__1.i = fr * z__2.i;
  2571.     curi.r = z__1.r, curi.i = z__1.i;
  2572. /*<       CMAG= ABS( CURI) >*/
  2573.     cmag = z_abs(&curi);
  2574. /*<       PH= CANG( CURI) >*/
  2575.     ph = cang_(&curi);
  2576. /*<    >*/
  2577.     s_wsfe(&io___161);
  2578.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  2579.     do_fio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
  2580.     do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  2581.     do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  2582.     do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  2583.     do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  2584.     do_fio(&c__2, (char *)&curi, (ftnlen)sizeof(doublereal));
  2585.     do_fio(&c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
  2586.     do_fio(&c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
  2587.     e_wsfe();
  2588. /*<   316 CONTINUE >*/
  2589. L316:
  2590.     ;
  2591.     }
  2592. /*<   308 IF( M.EQ.0) GOTO 310 >*/
  2593. L308:
  2594.     if (data_1.m == 0) {
  2595.     goto L310;
  2596.     }
  2597. /*<       WRITE( 6,197)  >*/
  2598.     s_wsfe(&io___162);
  2599.     e_wsfe();
  2600. /*<       J= N-2 >*/
  2601.     j = data_1.n - 2;
  2602. /*<       ITMP1= LD+1 >*/
  2603.     itmp1 = data_1.ld + 1;
  2604. /*<       DO 309  I=1, M >*/
  2605.     i__2 = data_1.m;
  2606.     for (i = 1; i <= i__2; ++i) {
  2607. /*<       J= J+3 >*/
  2608.     j += 3;
  2609. /*<       ITMP1= ITMP1-1 >*/
  2610.     --itmp1;
  2611. /*<       EX= CUR( J) >*/
  2612.     i__1 = j - 1;
  2613.     ex.r = crnt_1.cur[i__1].r, ex.i = crnt_1.cur[i__1].i;
  2614. /*<       EY= CUR( J+1) >*/
  2615.     i__1 = j;
  2616.     ey.r = crnt_1.cur[i__1].r, ey.i = crnt_1.cur[i__1].i;
  2617. /*<       EZ= CUR( J+2) >*/
  2618.     i__1 = j + 1;
  2619.     ez.r = crnt_1.cur[i__1].r, ez.i = crnt_1.cur[i__1].i;
  2620. /*<       ETH= EX* T1X( ITMP1)+ EY* T1Y( ITMP1)+ EZ* T1Z( ITMP1) >*/
  2621.     i__1 = itmp1 - 1;
  2622.     z__3.r = t1x[i__1] * ex.r, z__3.i = t1x[i__1] * ex.i;
  2623.     i__3 = itmp1 - 1;
  2624.     z__4.r = t1y[i__3] * ey.r, z__4.i = t1y[i__3] * ey.i;
  2625.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  2626.     i__4 = itmp1 - 1;
  2627.     z__5.r = t1z[i__4] * ez.r, z__5.i = t1z[i__4] * ez.i;
  2628.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  2629.     eth.r = z__1.r, eth.i = z__1.i;
  2630. /*<       EPH= EX* T2X( ITMP1)+ EY* T2Y( ITMP1)+ EZ* T2Z( ITMP1) >*/
  2631.     i__1 = itmp1 - 1;
  2632.     z__3.r = t2x[i__1] * ex.r, z__3.i = t2x[i__1] * ex.i;
  2633.     i__3 = itmp1 - 1;
  2634.     z__4.r = t2y[i__3] * ey.r, z__4.i = t2y[i__3] * ey.i;
  2635.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  2636.     i__4 = itmp1 - 1;
  2637.     z__5.r = t2z[i__4] * ez.r, z__5.i = t2z[i__4] * ez.i;
  2638.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  2639.     eph.r = z__1.r, eph.i = z__1.i;
  2640. /*<       ETHM= ABS( ETH) >*/
  2641.     ethm = z_abs(ð);
  2642. /*<       ETHA= CANG( ETH) >*/
  2643.     etha = cang_(ð);
  2644. /*<       EPHM= ABS( EPH) >*/
  2645.     ephm = z_abs(&eph);
  2646. /* 309   WRITE(6,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA
  2647. ,E */
  2648. /*     1X,EY, EZ */
  2649. /* *** */
  2650. /*<       EPHA= CANG( EPH) >*/
  2651.     epha = cang_(&eph);
  2652. /*<    >*/
  2653.     s_wsfe(&io___172);
  2654.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  2655.     do_fio(&c__1, (char *)&data_1.x[itmp1 - 1], (ftnlen)sizeof(doublereal)
  2656.         );
  2657.     do_fio(&c__1, (char *)&data_1.y[itmp1 - 1], (ftnlen)sizeof(doublereal)
  2658.         );
  2659.     do_fio(&c__1, (char *)&data_1.z[itmp1 - 1], (ftnlen)sizeof(doublereal)
  2660.         );
  2661.     do_fio(&c__1, (char *)ðm, (ftnlen)sizeof(doublereal));
  2662.     do_fio(&c__1, (char *)ða, (ftnlen)sizeof(doublereal));
  2663.     do_fio(&c__1, (char *)&ephm, (ftnlen)sizeof(doublereal));
  2664.     do_fio(&c__1, (char *)&epha, (ftnlen)sizeof(doublereal));
  2665.     do_fio(&c__2, (char *)&ex, (ftnlen)sizeof(doublereal));
  2666.     do_fio(&c__2, (char *)&ey, (ftnlen)sizeof(doublereal));
  2667.     do_fio(&c__2, (char *)&ez, (ftnlen)sizeof(doublereal));
  2668.     e_wsfe();
  2669. /*<       IF( IPLP1.NE.1) GOTO 309 >*/
  2670.     if (plot_1.iplp1 != 1) {
  2671.         goto L309;
  2672.     }
  2673. /*<       IF( IPLP3.EQ.1) WRITE( 8,*)  EX >*/
  2674.     if (plot_1.iplp3 == 1) {
  2675.         s_wsle(&io___173);
  2676.         do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(doublecomplex));
  2677.         e_wsle();
  2678.     }
  2679. /*<       IF( IPLP3.EQ.2) WRITE( 8,*)  EY >*/
  2680.     if (plot_1.iplp3 == 2) {
  2681.         s_wsle(&io___174);
  2682.         do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(doublecomplex));
  2683.         e_wsle();
  2684.     }
  2685. /*<       IF( IPLP3.EQ.3) WRITE( 8,*)  EZ >*/
  2686.     if (plot_1.iplp3 == 3) {
  2687.         s_wsle(&io___175);
  2688.         do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(doublecomplex));
  2689.         e_wsle();
  2690.     }
  2691. /*<       IF( IPLP3.EQ.4) WRITE( 8,*)  EX, EY, EZ >*/
  2692.     if (plot_1.iplp3 == 4) {
  2693.         s_wsle(&io___176);
  2694.         do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(doublecomplex));
  2695.         do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(doublecomplex));
  2696.         do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(doublecomplex));
  2697.         e_wsle();
  2698.     }
  2699. /* *** */
  2700. /*<   309 CONTINUE >*/
  2701. L309:
  2702.     ;
  2703.     }
  2704. /*<   310 IF( IXTYP.NE.0.AND. IXTYP.NE.5) GOTO 70 >*/
  2705. L310:
  2706.     if (fpat_1.ixtyp != 0 && fpat_1.ixtyp != 5) {
  2707.     goto L70;
  2708.     }
  2709. /*<       TMP1= PIN- PNLS- PLOSS >*/
  2710.     tmp1 = netcx_1.pin - netcx_1.pnls - fpat_1.ploss;
  2711. /*<       TMP2=100.* TMP1/ PIN >*/
  2712.     tmp2 = tmp1 * 100. / netcx_1.pin;
  2713. /*<       WRITE( 6,166)  PIN, TMP1, PLOSS, PNLS, TMP2 >*/
  2714.     s_wsfe(&io___177);
  2715.     do_fio(&c__1, (char *)&netcx_1.pin, (ftnlen)sizeof(doublereal));
  2716.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  2717.     do_fio(&c__1, (char *)&fpat_1.ploss, (ftnlen)sizeof(doublereal));
  2718.     do_fio(&c__1, (char *)&netcx_1.pnls, (ftnlen)sizeof(doublereal));
  2719.     do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  2720.     e_wsfe();
  2721. /*<    70 CONTINUE >*/
  2722. L70:
  2723. /*<       IGO=4 >*/
  2724.     igo = 4;
  2725. /*<       IF( NCOUP.GT.0) CALL COUPLE( CUR, WLAM) >*/
  2726.     if (yparm_1.ncoup > 0) {
  2727.     couple_(crnt_1.cur, &data_1.wlam);
  2728.     }
  2729. /*<       IF( IFLOW.NE.7) GOTO 71 >*/
  2730.     if (iflow != 7) {
  2731.     goto L71;
  2732.     }
  2733. /*<       IF( IXTYP.GT.0.AND. IXTYP.LT.4) GOTO 113 >*/
  2734.     if (fpat_1.ixtyp > 0 && fpat_1.ixtyp < 4) {
  2735.     goto L113;
  2736.     }
  2737. /*<       IF( NFRQ.NE.1) GOTO 120 >*/
  2738.     if (nfrq != 1) {
  2739.     goto L120;
  2740.     }
  2741. /*<       WRITE( 6,135)  >*/
  2742.     s_wsfe(&io___178);
  2743.     e_wsfe();
  2744. /*<       GOTO 14 >*/
  2745.     goto L14;
  2746.  
  2747. /*     NEAR FIELD CALCULATION */
  2748.  
  2749. /*<    71 IGO=5 >*/
  2750. L71:
  2751.     igo = 5;
  2752. /*<    72 IF( NEAR.EQ.(-1)) GOTO 78 >*/
  2753. L72:
  2754.     if (fpat_1.near == -1) {
  2755.     goto L78;
  2756.     }
  2757. /*<       CALL NFPAT >*/
  2758.     nfpat_();
  2759. /*<       IF( MHZ.EQ. NFRQ) NEAR=-1 >*/
  2760.     if (mhz == nfrq) {
  2761.     fpat_1.near = -1;
  2762.     }
  2763. /*<       IF( NFRQ.NE.1) GOTO 78 >*/
  2764.     if (nfrq != 1) {
  2765.     goto L78;
  2766.     }
  2767. /*<       WRITE( 6,135)  >*/
  2768.     s_wsfe(&io___179);
  2769.     e_wsfe();
  2770.  
  2771. /*     STANDARD FAR FIELD CALCULATION */
  2772.  
  2773. /*<       GOTO 14 >*/
  2774.     goto L14;
  2775. /*<    78 IF( IFAR.EQ.-1) GOTO 113 >*/
  2776. L78:
  2777.     if (gnd_1.ifar == -1) {
  2778.     goto L113;
  2779.     }
  2780. /*<       PINR= PIN >*/
  2781.     fpat_1.pinr = netcx_1.pin;
  2782. /*<       PNLR= PNLS >*/
  2783.     fpat_1.pnlr = netcx_1.pnls;
  2784. /*<       CALL RDPAT >*/
  2785.     rdpat_();
  2786. /*<   113 IF( IXTYP.EQ.0.OR. IXTYP.GE.4) GOTO 119 >*/
  2787. L113:
  2788.     if (fpat_1.ixtyp == 0 || fpat_1.ixtyp >= 4) {
  2789.     goto L119;
  2790.     }
  2791. /*<       NTHIC= NTHIC+1 >*/
  2792.     ++nthic;
  2793. /*<       INC= INC+1 >*/
  2794.     ++inc;
  2795. /*<       XPR1= XPR1+ XPR4 >*/
  2796.     xpr1 += xpr4;
  2797. /*<       IF( NTHIC.LE. NTHI) GOTO 54 >*/
  2798.     if (nthic <= nthi) {
  2799.     goto L54;
  2800.     }
  2801. /*<       NTHIC=1 >*/
  2802.     nthic = 1;
  2803. /*<       XPR1= THETIS >*/
  2804.     xpr1 = thetis;
  2805. /*<       XPR2= XPR2+ XPR5 >*/
  2806.     xpr2 += xpr5;
  2807. /*<       NPHIC= NPHIC+1 >*/
  2808.     ++nphic;
  2809. /*<       IF( NPHIC.LE. NPHI) GOTO 54 >*/
  2810.     if (nphic <= nphi) {
  2811.     goto L54;
  2812.     }
  2813. /*<       NPHIC=1 >*/
  2814.     nphic = 1;
  2815. /*<       XPR2= PHISS >*/
  2816.     xpr2 = phiss;
  2817. /*     NORMALIZED RECEIVING PATTERN PRINTED */
  2818. /*<       IF( IPTFLG.LT.2) GOTO 119 >*/
  2819.     if (iptflg < 2) {
  2820.     goto L119;
  2821.     }
  2822. /*<       ITMP1= NTHI* NPHI >*/
  2823.     itmp1 = nthi * nphi;
  2824. /*<       IF( ITMP1.LE. NORMF) GOTO 114 >*/
  2825.     if (itmp1 <= normf) {
  2826.     goto L114;
  2827.     }
  2828. /*<       ITMP1= NORMF >*/
  2829.     itmp1 = normf;
  2830. /*<       WRITE( 6,181)  >*/
  2831.     s_wsfe(&io___180);
  2832.     e_wsfe();
  2833. /*<   114 TMP1= FNORM(1) >*/
  2834. L114:
  2835.     tmp1 = fnorm[0];
  2836. /*<       DO 115  J=2, ITMP1 >*/
  2837.     i__2 = itmp1;
  2838.     for (j = 2; j <= i__2; ++j) {
  2839. /*<       IF( FNORM( J).GT. TMP1) TMP1= FNORM( J) >*/
  2840.     if (fnorm[j - 1] > tmp1) {
  2841.         tmp1 = fnorm[j - 1];
  2842.     }
  2843. /*<   115 CONTINUE >*/
  2844. /* L115: */
  2845.     }
  2846. /*<       WRITE( 6,182)  TMP1, XPR3, HPOL( IXTYP), XPR6, ISAVE >*/
  2847.     s_wsfe(&io___181);
  2848.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  2849.     do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
  2850.     do_fio(&c__1, hpol + (fpat_1.ixtyp - 1) * 6, 6L);
  2851.     do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
  2852.     do_fio(&c__1, (char *)&isave, (ftnlen)sizeof(integer));
  2853.     e_wsfe();
  2854. /*<       DO 118  J=1, NPHI >*/
  2855.     i__2 = nphi;
  2856.     for (j = 1; j <= i__2; ++j) {
  2857. /*<       ITMP2= NTHI*( J-1) >*/
  2858.     itmp2 = nthi * (j - 1);
  2859. /*<       DO 116  I=1, NTHI >*/
  2860.     i__1 = nthi;
  2861.     for (i = 1; i <= i__1; ++i) {
  2862. /*<       ITMP3= I+ ITMP2 >*/
  2863.         itmp3 = i + itmp2;
  2864. /*<       IF( ITMP3.GT. ITMP1) GOTO 117 >*/
  2865.         if (itmp3 > itmp1) {
  2866.         goto L117;
  2867.         }
  2868. /*<       TMP2= FNORM( ITMP3)/ TMP1 >*/
  2869.         tmp2 = fnorm[itmp3 - 1] / tmp1;
  2870. /*<       TMP3= DB20( TMP2) >*/
  2871.         tmp3 = db20_(&tmp2);
  2872. /*<       WRITE( 6,183)  XPR1, XPR2, TMP3, TMP2 >*/
  2873.         s_wsfe(&io___182);
  2874.         do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
  2875.         do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
  2876.         do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
  2877.         do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  2878.         e_wsfe();
  2879. /*<       XPR1= XPR1+ XPR4 >*/
  2880.         xpr1 += xpr4;
  2881. /*<   116 CONTINUE >*/
  2882. /* L116: */
  2883.     }
  2884. /*<   117 XPR1= THETIS >*/
  2885. L117:
  2886.     xpr1 = thetis;
  2887. /*<       XPR2= XPR2+ XPR5 >*/
  2888.     xpr2 += xpr5;
  2889. /*<   118 CONTINUE >*/
  2890. /* L118: */
  2891.     }
  2892. /*<       XPR2= PHISS >*/
  2893.     xpr2 = phiss;
  2894. /*<   119 IF( MHZ.EQ. NFRQ) IFAR=-1 >*/
  2895. L119:
  2896.     if (mhz == nfrq) {
  2897.     gnd_1.ifar = -1;
  2898.     }
  2899. /*<       IF( NFRQ.NE.1) GOTO 120 >*/
  2900.     if (nfrq != 1) {
  2901.     goto L120;
  2902.     }
  2903. /*<       WRITE( 6,135)  >*/
  2904.     s_wsfe(&io___183);
  2905.     e_wsfe();
  2906. /*<       GOTO 14 >*/
  2907.     goto L14;
  2908. /*<   120 MHZ= MHZ+1 >*/
  2909. L120:
  2910.     ++mhz;
  2911. /*<       IF( MHZ.LE. NFRQ) GOTO 42 >*/
  2912.     if (mhz <= nfrq) {
  2913.     goto L42;
  2914.     }
  2915. /*<       IF( IPED.EQ.0) GOTO 123 >*/
  2916.     if (iped == 0) {
  2917.     goto L123;
  2918.     }
  2919. /*<       IF( NVQD.LT.1) GOTO 199 >*/
  2920.     if (vsorc_1.nvqd < 1) {
  2921.     goto L199;
  2922.     }
  2923. /*<       WRITE( 6,184)  IVQD( NVQD), ZPNORM >*/
  2924.     s_wsfe(&io___184);
  2925.     do_fio(&c__1, (char *)&vsorc_1.ivqd[vsorc_1.nvqd - 1], (ftnlen)sizeof(
  2926.         integer));
  2927.     do_fio(&c__1, (char *)&zpnorm, (ftnlen)sizeof(doublereal));
  2928.     e_wsfe();
  2929. /*<       GOTO 204 >*/
  2930.     goto L204;
  2931. /*<   199 WRITE( 6,184)  ISANT( NSANT), ZPNORM >*/
  2932. L199:
  2933.     s_wsfe(&io___185);
  2934.     do_fio(&c__1, (char *)&vsorc_1.isant[vsorc_1.nsant - 1], (ftnlen)sizeof(
  2935.         integer));
  2936.     do_fio(&c__1, (char *)&zpnorm, (ftnlen)sizeof(doublereal));
  2937.     e_wsfe();
  2938. /*<   204 ITMP1= NFRQ >*/
  2939. L204:
  2940.     itmp1 = nfrq;
  2941. /*<       IF( ITMP1.LE.( NORMF/4)) GOTO 121 >*/
  2942.     if (itmp1 <= normf / 4) {
  2943.     goto L121;
  2944.     }
  2945. /*<       ITMP1= NORMF/4 >*/
  2946.     itmp1 = normf / 4;
  2947. /*<       WRITE( 6,185)  >*/
  2948.     s_wsfe(&io___186);
  2949.     e_wsfe();
  2950. /*<   121 IF( IFRQ.EQ.0) TMP1= FMHZ-( NFRQ-1)* DELFRQ >*/
  2951. L121:
  2952.     if (ifrq == 0) {
  2953.     tmp1 = save_1.fmhz - (nfrq - 1) * delfrq;
  2954.     }
  2955. /*<       IF( IFRQ.EQ.1) TMP1= FMHZ/( DELFRQ**( NFRQ-1)) >*/
  2956.     if (ifrq == 1) {
  2957.     i__2 = nfrq - 1;
  2958.     tmp1 = save_1.fmhz / pow_di(&delfrq, &i__2);
  2959.     }
  2960. /*<       DO 122  I=1, ITMP1 >*/
  2961.     i__2 = itmp1;
  2962.     for (i = 1; i <= i__2; ++i) {
  2963. /*<       ITMP2= I+4*( I-1) >*/
  2964.     itmp2 = i + (i - 1 << 2);
  2965. /*<       TMP2= FNORM( ITMP2)/ ZPNORM >*/
  2966.     tmp2 = fnorm[itmp2 - 1] / zpnorm;
  2967. /*<       TMP3= FNORM( ITMP2+1)/ ZPNORM >*/
  2968.     tmp3 = fnorm[itmp2] / zpnorm;
  2969. /*<       TMP4= FNORM( ITMP2+2)/ ZPNORM >*/
  2970.     tmp4 = fnorm[itmp2 + 1] / zpnorm;
  2971. /*<       TMP5= FNORM( ITMP2+3) >*/
  2972.     tmp5 = fnorm[itmp2 + 2];
  2973. /*<    >*/
  2974.     s_wsfe(&io___187);
  2975.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  2976.     do_fio(&c__1, (char *)&fnorm[itmp2 - 1], (ftnlen)sizeof(doublereal));
  2977.     do_fio(&c__1, (char *)&fnorm[itmp2], (ftnlen)sizeof(doublereal));
  2978.     do_fio(&c__1, (char *)&fnorm[itmp2 + 1], (ftnlen)sizeof(doublereal));
  2979.     do_fio(&c__1, (char *)&fnorm[itmp2 + 2], (ftnlen)sizeof(doublereal));
  2980.     do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  2981.     do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
  2982.     do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
  2983.     do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
  2984.     e_wsfe();
  2985. /*<       IF( IFRQ.EQ.0) TMP1= TMP1+ DELFRQ >*/
  2986.     if (ifrq == 0) {
  2987.         tmp1 += delfrq;
  2988.     }
  2989. /*<       IF( IFRQ.EQ.1) TMP1= TMP1* DELFRQ >*/
  2990.     if (ifrq == 1) {
  2991.         tmp1 *= delfrq;
  2992.     }
  2993. /*<   122 CONTINUE >*/
  2994. /* L122: */
  2995.     }
  2996. /*<       WRITE( 6,135)  >*/
  2997.     s_wsfe(&io___188);
  2998.     e_wsfe();
  2999. /*<   123 CONTINUE >*/
  3000. L123:
  3001. /*<       NFRQ=1 >*/
  3002.     nfrq = 1;
  3003. /*<       MHZ=1 >*/
  3004.     mhz = 1;
  3005. /*<       GOTO 14 >*/
  3006.     goto L14;
  3007. /*<   125 FORMAT(A2,19A4) >*/
  3008. /*<   126 FORMAT('1') >*/
  3009. /*<    >*/
  3010. /*<   128 FORMAT(////,37X,'- - - - COMMENTS - - - -',//) >*/
  3011. /*<   129 FORMAT(25X,20A4) >*/
  3012. /*<   130 FORMAT(///,10X,'INCORRECT LABEL FOR A COMMENT CARD') >*/
  3013. /*<   135 FORMAT(/////) >*/
  3014. /*<   136 FORMAT(A2,I3,3I5,6E10.3) >*/
  3015. /* L136: */
  3016. /*<    >*/
  3017. /*<   138 FORMAT(///,10X,'FAULTY DATA CARD LABEL AFTER GEOMETRY SECTION') >*/
  3018. /*<    >*/
  3019. /*<    >*/
  3020. /*<    >*/
  3021. /*<    >*/
  3022. /*<    >*/
  3023. /*<    >*/
  3024. /*<   146 FORMAT(///,30X,' - - - STRUCTURE IMPEDANCE LOADING - - -') >*/
  3025. /*<   147 FORMAT(/,35X,'THIS STRUCTURE IS NOT LOADED') >*/
  3026. /*<   148 FORMAT(///,34X,'- - - ANTENNA ENVIRONMENT - - -',/) >*/
  3027. /*<   149 FORMAT(40X,'MEDIUM UNDER SCREEN -') >*/
  3028. /*<    >*/
  3029. /*<   151 FORMAT(42X,'PERFECT GROUND') >*/
  3030. /*<   152 FORMAT(44X,'FREE SPACE') >*/
  3031. /*<    >*/
  3032. /*<   154 FORMAT(///,40X,'- - - EXCITATION - - -') >*/
  3033. /*<    >*/
  3034. /*<    >*/
  3035. /*<   157 FORMAT(4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2) >*/
  3036. /*<   158 FORMAT(///,44X,'- - - NETWORK DATA - - -') >*/
  3037. /*<    >*/
  3038. /*<    >*/
  3039. /*<    >*/
  3040. /*<    >*/
  3041. /*<    >*/
  3042. /*<   164 FORMAT(10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5) >*/
  3043. /*<   165 FORMAT(1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3) >*/
  3044. /*<    >*/
  3045. /*<    >*/
  3046. /*<    >*/
  3047. /*<    >*/
  3048. /*<   183 FORMAT(20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4) >*/
  3049. /*<    >*/
  3050. /*<    >*/
  3051. /*<    >*/
  3052. /*<    >*/
  3053. /*<    >*/
  3054. /*<   198 FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2) >*/
  3055. /*<   201 FORMAT(/,' RUN TIME =',F10.3) >*/
  3056. /*<    >*/
  3057. /*<   321 FORMAT(/,20X,'THE EXTENDED THIN WIRE KERNEL WILL BE USED') >*/
  3058. /*<   303 FORMAT(/,' ERROR - ',A2,' CARD IS NOT ALLOWED WITH N.G.F.') >*/
  3059. /*<   327 FORMAT(/,35X,' LOADING ONLY IN N.G.F. SECTION') >*/
  3060. /*<   302 FORMAT(' ERROR - N.G.F. IN USE.  CANNOT WRITE NEW N.G.F.') >*/
  3061. /*<    >*/
  3062. /*<    >*/
  3063. /*<    >*/
  3064. /*<   392 FORMAT(40X,'FINITE GROUND.  SOMMERFELD SOLUTION') >*/
  3065. /*<    >*/
  3066. /*<       END >*/
  3067. } /* MAIN__ */
  3068.  
  3069. #undef sab
  3070. #undef cab
  3071. #undef t2z
  3072. #undef t2y
  3073. #undef t2x
  3074. #undef t1z
  3075. #undef t1y
  3076. #undef t1x
  3077. #undef z2
  3078. #undef y2
  3079. #undef x2
  3080.  
  3081.  
  3082. /* *** */
  3083. /*     DOUBLE PRECISION 6/4/85 */
  3084.  
  3085. /*<       SUBROUTINE ARC( ITG, NS, RADA, ANG1, ANG2, RAD) >*/
  3086. /* Subroutine */ int arc_(itg, ns, rada, ang1, ang2, rad)
  3087. integer *itg, *ns;
  3088. doublereal *rada, *ang1, *ang2, *rad;
  3089. {
  3090.     /* Initialized data */
  3091.  
  3092.     static doublereal ta = .01745329252;
  3093.  
  3094.     /* Format strings */
  3095.     static char fmt_3[] = "(\002 ERROR -- ARC ANGLE EXCEEDS 360. DEGREES\002)"
  3096.         ;
  3097.  
  3098.     /* System generated locals */
  3099.     integer i__1;
  3100.     doublereal d__1;
  3101.  
  3102.     /* Builtin functions */
  3103.     integer s_wsfe(), e_wsfe();
  3104.     /* Subroutine */ int s_stop();
  3105.     double cos(), sin();
  3106.  
  3107.     /* Local variables */
  3108.     static doublereal dang;
  3109.     static integer i;
  3110. #define x2 ((doublereal *)&data_1 + 1800)
  3111. #define y2 ((doublereal *)&data_1 + 3000)
  3112. #define z2 ((doublereal *)&data_1 + 3600)
  3113.     static doublereal xs1, xs2, zs1, zs2, ang;
  3114.     static integer ist;
  3115.  
  3116.     /* Fortran I/O blocks */
  3117.     static cilist io___194 = { 0, 6, 0, fmt_3, 0 };
  3118.  
  3119.  
  3120. /* *** */
  3121.  
  3122. /*     ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS */
  3123.  
  3124. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  3125. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  3126. /*<       DIMENSION  X2(1), Y2(1), Z2(1) >*/
  3127. /*<    >*/
  3128. /*<       EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET) >*/
  3129. /*<       DATA   TA/.01745329252D+0/ >*/
  3130. /*<       IST= N+1 >*/
  3131.     ist = data_1.n + 1;
  3132. /*<       N= N+ NS >*/
  3133.     data_1.n += *ns;
  3134. /*<       NP= N >*/
  3135.     data_1.np = data_1.n;
  3136. /*<       MP= M >*/
  3137.     data_1.mp = data_1.m;
  3138. /*<       IPSYM=0 >*/
  3139.     data_1.ipsym = 0;
  3140. /*<       IF( NS.LT.1) RETURN >*/
  3141.     if (*ns < 1) {
  3142.     return 0;
  3143.     }
  3144. /*<       IF( ABS( ANG2- ANG1).LT.360.00001D+0) GOTO 1 >*/
  3145.     if ((d__1 = *ang2 - *ang1, abs(d__1)) < 360.00001) {
  3146.     goto L1;
  3147.     }
  3148. /*<       WRITE( 6,3)  >*/
  3149.     s_wsfe(&io___194);
  3150.     e_wsfe();
  3151. /*<       STOP >*/
  3152.     s_stop("", 0L);
  3153. /*<     1 ANG= ANG1* TA >*/
  3154. L1:
  3155.     ang = *ang1 * ta;
  3156. /*<       DANG=( ANG2- ANG1)* TA/ NS >*/
  3157.     dang = (*ang2 - *ang1) * ta / *ns;
  3158. /*<       XS1= RADA* COS( ANG) >*/
  3159.     xs1 = *rada * cos(ang);
  3160. /*<       ZS1= RADA* SIN( ANG) >*/
  3161.     zs1 = *rada * sin(ang);
  3162. /*<       DO 2  I= IST, N >*/
  3163.     i__1 = data_1.n;
  3164.     for (i = ist; i <= i__1; ++i) {
  3165. /*<       ANG= ANG+ DANG >*/
  3166.     ang += dang;
  3167. /*<       XS2= RADA* COS( ANG) >*/
  3168.     xs2 = *rada * cos(ang);
  3169. /*<       ZS2= RADA* SIN( ANG) >*/
  3170.     zs2 = *rada * sin(ang);
  3171. /*<       X( I)= XS1 >*/
  3172.     data_1.x[i - 1] = xs1;
  3173. /*<       Y( I)=0. >*/
  3174.     data_1.y[i - 1] = 0.;
  3175. /*<       Z( I)= ZS1 >*/
  3176.     data_1.z[i - 1] = zs1;
  3177. /*<       X2( I)= XS2 >*/
  3178.     x2[i - 1] = xs2;
  3179. /*<       Y2( I)=0. >*/
  3180.     y2[i - 1] = 0.;
  3181. /*<       Z2( I)= ZS2 >*/
  3182.     z2[i - 1] = zs2;
  3183. /*<       XS1= XS2 >*/
  3184.     xs1 = xs2;
  3185. /*<       ZS1= ZS2 >*/
  3186.     zs1 = zs2;
  3187. /*<       BI( I)= RAD >*/
  3188.     data_1.bi[i - 1] = *rad;
  3189. /*<     2 ITAG( I)= ITG >*/
  3190. /* L2: */
  3191.     data_1.itag[i - 1] = *itg;
  3192.     }
  3193.  
  3194. /*<       RETURN >*/
  3195.     return 0;
  3196. /*<     3 FORMAT(' ERROR -- ARC ANGLE EXCEEDS 360. DEGREES') >*/
  3197. /*<       END >*/
  3198. } /* arc_ */
  3199.  
  3200. #undef z2
  3201. #undef y2
  3202. #undef x2
  3203.  
  3204.  
  3205. /* *** */
  3206. /*     DOUBLE PRECISION 6/4/85 */
  3207.  
  3208. /*<       FUNCTION ATGN2( X, Y) >*/
  3209. doublereal atgn2_(x, y)
  3210. doublereal *x, *y;
  3211. {
  3212.     /* System generated locals */
  3213.     doublereal ret_val;
  3214.  
  3215.     /* Builtin functions */
  3216.     double atan2();
  3217.  
  3218. /* *** */
  3219.  
  3220. /*     ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0. */
  3221.  
  3222. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  3223. /*<       IF( X) 3,1,3 >*/
  3224.     if (*x != 0.) {
  3225.     goto L3;
  3226.     } else {
  3227.     goto L1;
  3228.     }
  3229. /*<     1 IF( Y) 3,2,3 >*/
  3230. L1:
  3231.     if (*y != 0.) {
  3232.     goto L3;
  3233.     } else {
  3234.     goto L2;
  3235.     }
  3236. /*<     2 ATGN2=0. >*/
  3237. L2:
  3238.     ret_val = 0.;
  3239. /*<       RETURN >*/
  3240.     return ret_val;
  3241. /*<     3 ATGN2= ATAN2( X, Y) >*/
  3242. L3:
  3243.     ret_val = atan2(*x, *y);
  3244. /*<       RETURN >*/
  3245.     return ret_val;
  3246. /*<       END >*/
  3247. } /* atgn2_ */
  3248.  
  3249. /* *** */
  3250. /*     DOUBLE PRECISION 6/4/85 */
  3251.  
  3252. /*<       SUBROUTINE BLCKOT( AR, NUNIT, IX1, IX2, NBLKS, NEOF) >*/
  3253. /* Subroutine */ int blckot_0_(n__, ar, nunit, ix1, ix2, nblks, neof)
  3254. int n__;
  3255. doublecomplex *ar;
  3256. integer *nunit, *ix1, *ix2, *nblks, *neof;
  3257. {
  3258.     /* Format strings */
  3259.     static char fmt_4[] = "(\002  EOF ON UNIT\002,i3,\002  NBLKS= \002,i3\
  3260. ,\002  NEOF= \002,i5)";
  3261.  
  3262.     /* System generated locals */
  3263.     integer i__1, i__2, i__3;
  3264.  
  3265.     /* Builtin functions */
  3266.     integer s_wsue(), do_uio(), e_wsue(), s_rsue(), e_rsue(), s_wsfe(), 
  3267.         do_fio(), e_wsfe();
  3268.     /* Subroutine */ int s_stop();
  3269.  
  3270.     /* Local variables */
  3271.     static integer i, j, i1, i2;
  3272.  
  3273.     /* Fortran I/O blocks */
  3274.     static cilist io___204 = { 0, 0, 0, 0, 0 };
  3275.     static cilist io___207 = { 0, 0, 1, 0, 0 };
  3276.     static cilist io___208 = { 0, 6, 0, fmt_4, 0 };
  3277.  
  3278.  
  3279. /* *** */
  3280.  
  3281. /*     BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILES 
  3282. */
  3283. /*     FOR THE OUT-OF-CORE MATRIX SOLUTION. */
  3284.  
  3285. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  3286. /*<       LOGICAL  ENF >*/
  3287. /*<       COMPLEX  AR >*/
  3288. /*<       DIMENSION  AR(1000) >*/
  3289. /*<       I1=( IX1+1)/2 >*/
  3290.     /* Parameter adjustments */
  3291.     --ar;
  3292.  
  3293.     /* Function Body */
  3294.     switch(n__) {
  3295.     case 1: goto L_blckin;
  3296.     }
  3297.  
  3298.     i1 = (*ix1 + 1) / 2;
  3299. /*<       I2=( IX2+1)/2 >*/
  3300.     i2 = (*ix2 + 1) / 2;
  3301. /*<     1 WRITE( NUNIT) ( AR( J), J= I1, I2) >*/
  3302. /* L1: */
  3303.     io___204.ciunit = *nunit;
  3304.     s_wsue(&io___204);
  3305.     i__1 = i2;
  3306.     for (j = i1; j <= i__1; ++j) {
  3307.     do_uio(&c__2, (char *)&ar[j], (ftnlen)sizeof(doublereal));
  3308.     }
  3309.     e_wsue();
  3310. /*<       RETURN >*/
  3311.     return 0;
  3312. /*<       ENTRY BLCKIN( AR, NUNIT, IX1, IX2, NBLKS, NEOF) >*/
  3313.  
  3314. L_blckin:
  3315. /*<       I1=( IX1+1)/2 >*/
  3316.     i1 = (*ix1 + 1) / 2;
  3317. /*<       I2=( IX2+1)/2 >*/
  3318.     i2 = (*ix2 + 1) / 2;
  3319. /*<       DO 2  I=1, NBLKS >*/
  3320.     i__1 = *nblks;
  3321.     for (i = 1; i <= i__1; ++i) {
  3322. /*     IF (ENF(NUNIT)) GO TO 3 */
  3323. /*<       READ( NUNIT,END=3) ( AR( J), J= I1, I2) >*/
  3324.     io___207.ciunit = *nunit;
  3325.     i__2 = s_rsue(&io___207);
  3326.     if (i__2 != 0) {
  3327.         goto L3;
  3328.     }
  3329.     i__3 = i2;
  3330.     for (j = i1; j <= i__3; ++j) {
  3331.         i__2 = do_uio(&c__2, (char *)&ar[j], (ftnlen)sizeof(doublereal));
  3332.         if (i__2 != 0) {
  3333.         goto L3;
  3334.         }
  3335.     }
  3336.     i__2 = e_rsue();
  3337.     if (i__2 != 0) {
  3338.         goto L3;
  3339.     }
  3340. /*<     2 CONTINUE >*/
  3341. /* L2: */
  3342.     }
  3343. /*<       RETURN >*/
  3344.     return 0;
  3345. /*<     3 WRITE( 6,4)  NUNIT, NBLKS, NEOF >*/
  3346. L3:
  3347.     s_wsfe(&io___208);
  3348.     do_fio(&c__1, (char *)&(*nunit), (ftnlen)sizeof(integer));
  3349.     do_fio(&c__1, (char *)&(*nblks), (ftnlen)sizeof(integer));
  3350.     do_fio(&c__1, (char *)&(*neof), (ftnlen)sizeof(integer));
  3351.     e_wsfe();
  3352. /*<       IF( NEOF.NE.777) STOP >*/
  3353.     if (*neof != 777) {
  3354.     s_stop("", 0L);
  3355.     }
  3356. /*<       NEOF=0 >*/
  3357.     *neof = 0;
  3358.  
  3359. /*<       RETURN >*/
  3360.     return 0;
  3361. /*<     4 FORMAT('  EOF ON UNIT',I3,'  NBLKS= ',I3,'  NEOF= ',I5) >*/
  3362. /*<       END >*/
  3363. } /* blckot_ */
  3364.  
  3365. /* Subroutine */ int blckot_(ar, nunit, ix1, ix2, nblks, neof)
  3366. doublecomplex *ar;
  3367. integer *nunit, *ix1, *ix2, *nblks, *neof;
  3368. {
  3369.     return blckot_0_(0, ar, nunit, ix1, ix2, nblks, neof);
  3370.     }
  3371.  
  3372. /* Subroutine */ int blckin_(ar, nunit, ix1, ix2, nblks, neof)
  3373. doublecomplex *ar;
  3374. integer *nunit, *ix1, *ix2, *nblks, *neof;
  3375. {
  3376.     return blckot_0_(1, ar, nunit, ix1, ix2, nblks, neof);
  3377.     }
  3378.  
  3379. /* *** */
  3380. /*     DOUBLE PRECISION 6/4/85 */
  3381.  
  3382. /*<       SUBROUTINE CABC( CURX) >*/
  3383. /* Subroutine */ int cabc_(curx)
  3384. doublecomplex *curx;
  3385. {
  3386.     /* Initialized data */
  3387.  
  3388.     static doublereal tp = 6.283185308;
  3389.     static struct {
  3390.     doublereal e_1[3];
  3391.     } equiv_6 = { 0., -.01666666667, 0. };
  3392.  
  3393.  
  3394.     /* System generated locals */
  3395.     integer i__1, i__2, i__3, i__4;
  3396.     doublereal d__1, d__2;
  3397.     doublecomplex z__1, z__2, z__3;
  3398.  
  3399.     /* Builtin functions */
  3400.     double d_imag(), log(), cos(), sin();
  3401.  
  3402.     /* Local variables */
  3403. #define ccjx ((doublereal *)&equiv_6)
  3404.     static doublecomplex curd;
  3405.     static integer i, j, k;
  3406.     static doublereal ai, ar;
  3407.     static integer is;
  3408.     static doublereal sh;
  3409.     static integer jx;
  3410.     static doublecomplex cs1, cs2;
  3411. #define t1x ((doublereal *)&data_1 + 1800)
  3412. #define t1y ((doublereal *)&data_1 + 3000)
  3413. #define t1z ((doublereal *)&data_1 + 3600)
  3414. #define t2x ((doublereal *)&data_1 + 4201)
  3415. #define t2y ((doublereal *)&data_1 + 4601)
  3416. #define t2z ((doublereal *)&data_1 + 5001)
  3417. #define ccj ((doublecomplex *)&equiv_6)
  3418.     extern /* Subroutine */ int tbf_();
  3419.     static integer jco1, jco2;
  3420.  
  3421. /* *** */
  3422.  
  3423. /*     CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND */
  3424. /*     COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE */
  3425. /*     CURRENT VECTOR CUR. */
  3426.  
  3427. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  3428. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  3429. /*<       COMPLEX  CUR, CURX, VQDS, CURD, CCJ, VSANT, VQD, CS1, CS2 >*/
  3430. /*<    >*/
  3431. /*<    >*/
  3432. /*<    >*/
  3433. /*<    >*/
  3434. /*<       COMMON  /ANGL/ SALP( NM) >*/
  3435. /*<       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
  3436. /*<       DIMENSION  CURX(1), CCJX(2) >*/
  3437. /*<    >*/
  3438. /*<       EQUIVALENCE(CCJ,CCJX) >*/
  3439. /*<       DATA   TP/6.283185308D+0/, CCJX/0.,-0.01666666667D+0/ >*/
  3440.     /* Parameter adjustments */
  3441.     --curx;
  3442.  
  3443.     /* Function Body */
  3444. /*<       IF( N.EQ.0) GOTO 6 >*/
  3445.     if (data_1.n == 0) {
  3446.     goto L6;
  3447.     }
  3448. /*<       DO 1  I=1, N >*/
  3449.     i__1 = data_1.n;
  3450.     for (i = 1; i <= i__1; ++i) {
  3451. /*<       AIR( I)=0. >*/
  3452.     crnt_1.air[i - 1] = 0.;
  3453. /*<       AII( I)=0. >*/
  3454.     crnt_1.aii[i - 1] = 0.;
  3455. /*<       BIR( I)=0. >*/
  3456.     crnt_1.bir[i - 1] = 0.;
  3457. /*<       BII( I)=0. >*/
  3458.     crnt_1.bii[i - 1] = 0.;
  3459. /*<       CIR( I)=0. >*/
  3460.     crnt_1.cir[i - 1] = 0.;
  3461. /*<     1 CII( I)=0. >*/
  3462. /* L1: */
  3463.     crnt_1.cii[i - 1] = 0.;
  3464.     }
  3465. /*<       DO 2  I=1, N >*/
  3466.     i__1 = data_1.n;
  3467.     for (i = 1; i <= i__1; ++i) {
  3468. /*<       AR= REAL( CURX( I)) >*/
  3469.     i__2 = i;
  3470.     ar = curx[i__2].r;
  3471. /*<       AI= AIMAG( CURX( I)) >*/
  3472.     ai = d_imag(&curx[i]);
  3473. /*<       CALL TBF( I,1) >*/
  3474.     tbf_(&i, &c__1);
  3475. /*<       DO 2  JX=1, JSNO >*/
  3476.     i__2 = segj_1.jsno;
  3477.     for (jx = 1; jx <= i__2; ++jx) {
  3478. /*<       J= JCO( JX) >*/
  3479.         j = segj_1.jco[jx - 1];
  3480. /*<       AIR( J)= AIR( J)+ AX( JX)* AR >*/
  3481.         crnt_1.air[j - 1] += segj_1.ax[jx - 1] * ar;
  3482. /*<       AII( J)= AII( J)+ AX( JX)* AI >*/
  3483.         crnt_1.aii[j - 1] += segj_1.ax[jx - 1] * ai;
  3484. /*<       BIR( J)= BIR( J)+ BX( JX)* AR >*/
  3485.         crnt_1.bir[j - 1] += segj_1.bx[jx - 1] * ar;
  3486. /*<       BII( J)= BII( J)+ BX( JX)* AI >*/
  3487.         crnt_1.bii[j - 1] += segj_1.bx[jx - 1] * ai;
  3488. /*<       CIR( J)= CIR( J)+ CX( JX)* AR >*/
  3489.         crnt_1.cir[j - 1] += segj_1.cx[jx - 1] * ar;
  3490. /*<     2 CII( J)= CII( J)+ CX( JX)* AI >*/
  3491. /* L2: */
  3492.         crnt_1.cii[j - 1] += segj_1.cx[jx - 1] * ai;
  3493.     }
  3494.     }
  3495. /*<       IF( NQDS.EQ.0) GOTO 4 >*/
  3496.     if (vsorc_1.nqds == 0) {
  3497.     goto L4;
  3498.     }
  3499. /*<       DO 3  IS=1, NQDS >*/
  3500.     i__2 = vsorc_1.nqds;
  3501.     for (is = 1; is <= i__2; ++is) {
  3502. /*<       I= IQDS( IS) >*/
  3503.     i = vsorc_1.iqds[is - 1];
  3504. /*<       JX= ICON1( I) >*/
  3505.     jx = data_1.icon1[i - 1];
  3506. /*<       ICON1( I)=0 >*/
  3507.     data_1.icon1[i - 1] = 0;
  3508. /*<       CALL TBF( I,0) >*/
  3509.     tbf_(&i, &c__0);
  3510. /*<       ICON1( I)= JX >*/
  3511.     data_1.icon1[i - 1] = jx;
  3512. /*<       SH= SI( I)*.5 >*/
  3513.     sh = data_1.si[i - 1] * .5;
  3514. /*<    >*/
  3515.     i__1 = is - 1;
  3516.     z__2.r = ccj->r * vsorc_1.vqds[i__1].r - ccj->i * vsorc_1.vqds[i__1]
  3517.         .i, z__2.i = ccj->r * vsorc_1.vqds[i__1].i + ccj->i * 
  3518.         vsorc_1.vqds[i__1].r;
  3519.     d__2 = (log(sh * 2. / data_1.bi[i - 1]) - 1.) * (segj_1.bx[
  3520.         segj_1.jsno - 1] * cos(tp * sh) + segj_1.cx[segj_1.jsno - 1] *
  3521.          sin(tp * sh));
  3522.     d__1 = d__2 * data_1.wlam;
  3523.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  3524.     curd.r = z__1.r, curd.i = z__1.i;
  3525. /*<       AR= REAL( CURD) >*/
  3526.     ar = curd.r;
  3527. /*<       AI= AIMAG( CURD) >*/
  3528.     ai = d_imag(&curd);
  3529. /*<       DO 3  JX=1, JSNO >*/
  3530.     i__1 = segj_1.jsno;
  3531.     for (jx = 1; jx <= i__1; ++jx) {
  3532. /*<       J= JCO( JX) >*/
  3533.         j = segj_1.jco[jx - 1];
  3534. /*<       AIR( J)= AIR( J)+ AX( JX)* AR >*/
  3535.         crnt_1.air[j - 1] += segj_1.ax[jx - 1] * ar;
  3536. /*<       AII( J)= AII( J)+ AX( JX)* AI >*/
  3537.         crnt_1.aii[j - 1] += segj_1.ax[jx - 1] * ai;
  3538. /*<       BIR( J)= BIR( J)+ BX( JX)* AR >*/
  3539.         crnt_1.bir[j - 1] += segj_1.bx[jx - 1] * ar;
  3540. /*<       BII( J)= BII( J)+ BX( JX)* AI >*/
  3541.         crnt_1.bii[j - 1] += segj_1.bx[jx - 1] * ai;
  3542. /*<       CIR( J)= CIR( J)+ CX( JX)* AR >*/
  3543.         crnt_1.cir[j - 1] += segj_1.cx[jx - 1] * ar;
  3544. /*<     3 CII( J)= CII( J)+ CX( JX)* AI >*/
  3545. /* L3: */
  3546.         crnt_1.cii[j - 1] += segj_1.cx[jx - 1] * ai;
  3547.     }
  3548.     }
  3549. /*<     4 DO 5  I=1, N >*/
  3550. L4:
  3551.     i__1 = data_1.n;
  3552.     for (i = 1; i <= i__1; ++i) {
  3553. /*<     5 CURX( I)= CMPLX( AIR( I)+ CIR( I), AII( I)+ CII( I)) >*/
  3554. /* L5: */
  3555.     i__2 = i;
  3556.     d__1 = crnt_1.air[i - 1] + crnt_1.cir[i - 1];
  3557.     d__2 = crnt_1.aii[i - 1] + crnt_1.cii[i - 1];
  3558.     z__1.r = d__1, z__1.i = d__2;
  3559.     curx[i__2].r = z__1.r, curx[i__2].i = z__1.i;
  3560.     }
  3561. /*     CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS 
  3562. */
  3563. /*<     6 IF( M.EQ.0) RETURN >*/
  3564. L6:
  3565.     if (data_1.m == 0) {
  3566.     return 0;
  3567.     }
  3568. /*<       K= LD- M >*/
  3569.     k = data_1.ld - data_1.m;
  3570. /*<       JCO1= N+2* M+1 >*/
  3571.     jco1 = data_1.n + (data_1.m << 1) + 1;
  3572. /*<       JCO2= JCO1+ M >*/
  3573.     jco2 = jco1 + data_1.m;
  3574. /*<       DO 7  I=1, M >*/
  3575.     i__2 = data_1.m;
  3576.     for (i = 1; i <= i__2; ++i) {
  3577. /*<       K= K+1 >*/
  3578.     ++k;
  3579. /*<       JCO1= JCO1-2 >*/
  3580.     jco1 += -2;
  3581. /*<       JCO2= JCO2-3 >*/
  3582.     jco2 += -3;
  3583. /*<       CS1= CURX( JCO1) >*/
  3584.     i__1 = jco1;
  3585.     cs1.r = curx[i__1].r, cs1.i = curx[i__1].i;
  3586. /*<       CS2= CURX( JCO1+1) >*/
  3587.     i__1 = jco1 + 1;
  3588.     cs2.r = curx[i__1].r, cs2.i = curx[i__1].i;
  3589. /*<       CURX( JCO2)= CS1* T1X( K)+ CS2* T2X( K) >*/
  3590.     i__1 = jco2;
  3591.     i__3 = k - 1;
  3592.     z__2.r = t1x[i__3] * cs1.r, z__2.i = t1x[i__3] * cs1.i;
  3593.     i__4 = k - 1;
  3594.     z__3.r = t2x[i__4] * cs2.r, z__3.i = t2x[i__4] * cs2.i;
  3595.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  3596.     curx[i__1].r = z__1.r, curx[i__1].i = z__1.i;
  3597. /*<       CURX( JCO2+1)= CS1* T1Y( K)+ CS2* T2Y( K) >*/
  3598.     i__1 = jco2 + 1;
  3599.     i__3 = k - 1;
  3600.     z__2.r = t1y[i__3] * cs1.r, z__2.i = t1y[i__3] * cs1.i;
  3601.     i__4 = k - 1;
  3602.     z__3.r = t2y[i__4] * cs2.r, z__3.i = t2y[i__4] * cs2.i;
  3603.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  3604.     curx[i__1].r = z__1.r, curx[i__1].i = z__1.i;
  3605. /*<     7 CURX( JCO2+2)= CS1* T1Z( K)+ CS2* T2Z( K) >*/
  3606. /* L7: */
  3607.     i__1 = jco2 + 2;
  3608.     i__3 = k - 1;
  3609.     z__2.r = t1z[i__3] * cs1.r, z__2.i = t1z[i__3] * cs1.i;
  3610.     i__4 = k - 1;
  3611.     z__3.r = t2z[i__4] * cs2.r, z__3.i = t2z[i__4] * cs2.i;
  3612.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  3613.     curx[i__1].r = z__1.r, curx[i__1].i = z__1.i;
  3614.     }
  3615. /*<       RETURN >*/
  3616.     return 0;
  3617. /*<       END >*/
  3618. } /* cabc_ */
  3619.  
  3620. #undef ccj
  3621. #undef t2z
  3622. #undef t2y
  3623. #undef t2x
  3624. #undef t1z
  3625. #undef t1y
  3626. #undef t1x
  3627. #undef ccjx
  3628.  
  3629.  
  3630. /* *** */
  3631. /*     DOUBLE PRECISION 6/4/85 */
  3632.  
  3633. /*<       FUNCTION CANG( Z) >*/
  3634. doublereal cang_(z)
  3635. doublecomplex *z;
  3636. {
  3637.     /* System generated locals */
  3638.     doublereal ret_val, d__1, d__2;
  3639.  
  3640.     /* Builtin functions */
  3641.     double d_imag();
  3642.  
  3643.     /* Local variables */
  3644.     extern doublereal atgn2_();
  3645.  
  3646. /* *** */
  3647.  
  3648. /*     CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES. */
  3649.  
  3650. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  3651. /*<       COMPLEX  Z >*/
  3652. /*<       CANG= ATGN2( AIMAG( Z), REAL( Z))*57.29577951D+0 >*/
  3653.     d__1 = d_imag(z);
  3654.     d__2 = z->r;
  3655.     ret_val = atgn2_(&d__1, &d__2) * 57.29577951;
  3656. /*<       RETURN >*/
  3657.     return ret_val;
  3658. /*<       END >*/
  3659. } /* cang_ */
  3660.  
  3661. /* *** */
  3662. /*     DOUBLE PRECISION 6/4/85 */
  3663.  
  3664. /*<       SUBROUTINE CMNGF( CB, CC, CD, NB, NC, ND, RKHX, IEXKX) >*/
  3665. /* Subroutine */ int cmngf_(cb, cc, cd, nb, nc, nd, rkhx, iexkx)
  3666. doublecomplex *cb, *cc, *cd;
  3667. integer *nb, *nc, *nd;
  3668. doublereal *rkhx;
  3669. integer *iexkx;
  3670. {
  3671.     /* System generated locals */
  3672.     integer cb_dim1, cb_offset, cc_dim1, cc_offset, cd_dim1, cd_offset, i__1, 
  3673.         i__2, i__3, i__4, i__5;
  3674.     doublereal d__1;
  3675.     doublecomplex z__1, z__2;
  3676.     alist al__1;
  3677.  
  3678.     /* Builtin functions */
  3679.     integer f_rew(), s_wsue(), do_uio(), e_wsue();
  3680.  
  3681.     /* Local variables */
  3682.     static integer iblk, neqn, neqp;
  3683.     extern /* Subroutine */ int cmss_();
  3684.     static integer neqs;
  3685.     extern /* Subroutine */ int cmws_(), cmsw_(), trio_(), cmww_();
  3686.     static integer isvv, i, j, neqsp, i1, i2, it, ir, ix, jx, im1, in2, im2, 
  3687.         in1;
  3688.     extern /* Subroutine */ int tbf_();
  3689.     static integer meq, imx, ist, isv, itx, jss, jsx, m1eq, m2eq;
  3690.  
  3691.     /* Fortran I/O blocks */
  3692.     static cilist io___256 = { 0, 14, 0, 0, 0 };
  3693.     static cilist io___259 = { 0, 12, 0, 0, 0 };
  3694.     static cilist io___260 = { 0, 15, 0, 0, 0 };
  3695.  
  3696.  
  3697. /* *** */
  3698. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  3699. /*     CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION 
  3700. */
  3701. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  3702. /*<    >*/
  3703. /*<       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
  3704. /*<    >*/
  3705. /*<    >*/
  3706. /*<    >*/
  3707. /*<    >*/
  3708. /*<       DIMENSION  CB( NB,1), CC( NC,1), CD( ND,1) >*/
  3709. /*<       RKH= RKHX >*/
  3710.     /* Parameter adjustments */
  3711.     cd_dim1 = *nd;
  3712.     cd_offset = cd_dim1 + 1;
  3713.     cd -= cd_offset;
  3714.     cc_dim1 = *nc;
  3715.     cc_offset = cc_dim1 + 1;
  3716.     cc -= cc_offset;
  3717.     cb_dim1 = *nb;
  3718.     cb_offset = cb_dim1 + 1;
  3719.     cb -= cb_offset;
  3720.  
  3721.     /* Function Body */
  3722.     dataj_1.rkh = *rkhx;
  3723. /*<       IEXK= IEXKX >*/
  3724.     dataj_1.iexk = *iexkx;
  3725. /*<       M1EQ=2* M1 >*/
  3726.     m1eq = data_1.m1 << 1;
  3727. /*<       M2EQ= M1EQ+1 >*/
  3728.     m2eq = m1eq + 1;
  3729. /*<       MEQ=2* M >*/
  3730.     meq = data_1.m << 1;
  3731. /*<       NEQP= ND- NPCON*2 >*/
  3732.     neqp = *nd - (segj_1.npcon << 1);
  3733. /*<       NEQS= NEQP- NSCON >*/
  3734.     neqs = neqp - segj_1.nscon;
  3735. /*<       NEQSP= NEQS+ NC >*/
  3736.     neqsp = neqs + *nc;
  3737. /*<       NEQN= NC+ N- N1 >*/
  3738.     neqn = *nc + data_1.n - data_1.n1;
  3739. /*<       ITX=1 >*/
  3740.     itx = 1;
  3741. /*<       IF( NSCON.GT.0) ITX=2 >*/
  3742.     if (segj_1.nscon > 0) {
  3743.     itx = 2;
  3744.     }
  3745. /*<       IF( ICASX.EQ.1) GOTO 1 >*/
  3746.     if (matpar_1.icasx == 1) {
  3747.     goto L1;
  3748.     }
  3749. /*<       REWIND 12 >*/
  3750.     al__1.aerr = 0;
  3751.     al__1.aunit = 12;
  3752.     f_rew(&al__1);
  3753. /*<       REWIND 14 >*/
  3754.     al__1.aerr = 0;
  3755.     al__1.aunit = 14;
  3756.     f_rew(&al__1);
  3757. /*<       REWIND 15 >*/
  3758.     al__1.aerr = 0;
  3759.     al__1.aunit = 15;
  3760.     f_rew(&al__1);
  3761. /*<       IF( ICASX.GT.2) GOTO 5 >*/
  3762.     if (matpar_1.icasx > 2) {
  3763.     goto L5;
  3764.     }
  3765. /*<     1 DO 4  J=1, ND >*/
  3766. L1:
  3767.     i__1 = *nd;
  3768.     for (j = 1; j <= i__1; ++j) {
  3769. /*<       DO 2  I=1, ND >*/
  3770.     i__2 = *nd;
  3771.     for (i = 1; i <= i__2; ++i) {
  3772. /*<     2 CD( I, J)=(0.,0.) >*/
  3773. /* L2: */
  3774.         i__3 = i + j * cd_dim1;
  3775.         cd[i__3].r = 0., cd[i__3].i = 0.;
  3776.     }
  3777. /*<       DO 3  I=1, NB >*/
  3778.     i__3 = *nb;
  3779.     for (i = 1; i <= i__3; ++i) {
  3780. /*<       CB( I, J)=(0.,0.) >*/
  3781.         i__2 = i + j * cb_dim1;
  3782.         cb[i__2].r = 0., cb[i__2].i = 0.;
  3783. /*<     3 CC( I, J)=(0.,0.) >*/
  3784. /* L3: */
  3785.         i__2 = i + j * cc_dim1;
  3786.         cc[i__2].r = 0., cc[i__2].i = 0.;
  3787.     }
  3788. /*<     4 CONTINUE >*/
  3789. /* L4: */
  3790.     }
  3791. /*<     5 IST= N- N1+1 >*/
  3792. L5:
  3793.     ist = data_1.n - data_1.n1 + 1;
  3794. /*<       IT= NPBX >*/
  3795.     it = matpar_1.npbx;
  3796. /*     LOOP THRU 24 FILLS B.  FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS) */
  3797. /*<       ISV=- NPBX >*/
  3798.     isv = -matpar_1.npbx;
  3799. /*<       DO 24  IBLK=1, NBBX >*/
  3800.     i__1 = matpar_1.nbbx;
  3801.     for (iblk = 1; iblk <= i__1; ++iblk) {
  3802. /*<       ISV= ISV+ NPBX >*/
  3803.     isv += matpar_1.npbx;
  3804. /*<       IF( IBLK.EQ. NBBX) IT= NLBX >*/
  3805.     if (iblk == matpar_1.nbbx) {
  3806.         it = matpar_1.nlbx;
  3807.     }
  3808. /*<       IF( ICASX.LT.3) GOTO 7 >*/
  3809.     if (matpar_1.icasx < 3) {
  3810.         goto L7;
  3811.     }
  3812. /*<       DO 6  J=1, ND >*/
  3813.     i__2 = *nd;
  3814.     for (j = 1; j <= i__2; ++j) {
  3815. /*<       DO 6  I=1, IT >*/
  3816.         i__3 = it;
  3817.         for (i = 1; i <= i__3; ++i) {
  3818. /*<     6 CB( I, J)=(0.,0.) >*/
  3819. /* L6: */
  3820.         i__4 = i + j * cb_dim1;
  3821.         cb[i__4].r = 0., cb[i__4].i = 0.;
  3822.         }
  3823.     }
  3824. /*<     7 I1= ISV+1 >*/
  3825. L7:
  3826.     i1 = isv + 1;
  3827. /*<       I2= ISV+ IT >*/
  3828.     i2 = isv + it;
  3829. /*<       IN2= I2 >*/
  3830.     in2 = i2;
  3831. /*<       IF( IN2.GT. N1) IN2= N1 >*/
  3832.     if (in2 > data_1.n1) {
  3833.         in2 = data_1.n1;
  3834.     }
  3835. /*<       IM1= I1- N1 >*/
  3836.     im1 = i1 - data_1.n1;
  3837. /*<       IM2= I2- N1 >*/
  3838.     im2 = i2 - data_1.n1;
  3839. /*<       IF( IM1.LT.1) IM1=1 >*/
  3840.     if (im1 < 1) {
  3841.         im1 = 1;
  3842.     }
  3843. /*<       IMX=1 >*/
  3844.     imx = 1;
  3845. /*<       IF( I1.LE. N1) IMX= N1- I1+2 >*/
  3846.     if (i1 <= data_1.n1) {
  3847.         imx = data_1.n1 - i1 + 2;
  3848.     }
  3849. /*     FILL B(WW),B(WS).  FOR ICASX=1,2 FILL D(WW),D(WS) */
  3850. /*<       IF( N2.GT. N) GOTO 12 >*/
  3851.     if (data_1.n2 > data_1.n) {
  3852.         goto L12;
  3853.     }
  3854. /*<       DO 11  J= N2, N >*/
  3855.     i__4 = data_1.n;
  3856.     for (j = data_1.n2; j <= i__4; ++j) {
  3857. /*<       CALL TRIO( J) >*/
  3858.         trio_(&j);
  3859. /*<       DO 9  I=1, JSNO >*/
  3860.         i__3 = segj_1.jsno;
  3861.         for (i = 1; i <= i__3; ++i) {
  3862. /*<       JSS= JCO( I) >*/
  3863.         jss = segj_1.jco[i - 1];
  3864. /*     SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMEN
  3865. T */
  3866. /*<       IF( JSS.LT. N2) GOTO 8 >*/
  3867.         if (jss < data_1.n2) {
  3868.             goto L8;
  3869.         }
  3870. /*<       JCO( I)= JSS- N1 >*/
  3871.         segj_1.jco[i - 1] = jss - data_1.n1;
  3872. /*     SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEG
  3873. MENT */
  3874. /*<       GOTO 9 >*/
  3875.         goto L9;
  3876. /*<     8 JCO( I)= NEQS+ ICONX( JSS) >*/
  3877. L8:
  3878.         segj_1.jco[i - 1] = neqs + data_1.iconx[jss - 1];
  3879. /*<     9 CONTINUE >*/
  3880. L9:
  3881.         ;
  3882.         }
  3883. /*<       IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0) >*/
  3884.         if (i1 <= in2) {
  3885.         cmww_(&j, &i1, &in2, &cb[cb_offset], nb, &cb[cb_offset], nb, &
  3886.             c__0);
  3887.         }
  3888. /*<    >*/
  3889.         if (im1 <= im2) {
  3890.         cmws_(&j, &im1, &im2, &cb[imx + cb_dim1], nb, &cb[cb_offset], 
  3891.             nb, &c__0);
  3892.         }
  3893. /*<       IF( ICASX.GT.2) GOTO 11 >*/
  3894.         if (matpar_1.icasx > 2) {
  3895.         goto L11;
  3896.         }
  3897. /*<       CALL CMWW( J, N2, N, CD, ND, CD, ND,1) >*/
  3898.         cmww_(&j, &data_1.n2, &data_1.n, &cd[cd_offset], nd, &cd[
  3899.             cd_offset], nd, &c__1);
  3900. /*     LOADING IN D(WW) */
  3901. /*<       IF( M2.LE. M) CALL CMWS( J, M2EQ, MEQ, CD(1, IST), ND, CD, ND,1) >*/
  3902.         if (data_1.m2 <= data_1.m) {
  3903.         cmws_(&j, &m2eq, &meq, &cd[ist * cd_dim1 + 1], nd, &cd[
  3904.             cd_offset], nd, &c__1);
  3905.         }
  3906. /*<       IF( NLOAD.EQ.0) GOTO 11 >*/
  3907.         if (zload_1.nload == 0) {
  3908.         goto L11;
  3909.         }
  3910. /*<       IR= J- N1 >*/
  3911.         ir = j - data_1.n1;
  3912. /*<       EXK= ZARRAY( J) >*/
  3913.         i__3 = j - 1;
  3914.         dataj_1.exk.r = zload_1.zarray[i__3].r, dataj_1.exk.i = 
  3915.             zload_1.zarray[i__3].i;
  3916. /*<       DO 10  I=1, JSNO >*/
  3917.         i__3 = segj_1.jsno;
  3918.         for (i = 1; i <= i__3; ++i) {
  3919. /*<       JSS= JCO( I) >*/
  3920.         jss = segj_1.jco[i - 1];
  3921. /*<    10 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK >*/
  3922. /* L10: */
  3923.         i__2 = jss + ir * cd_dim1;
  3924.         i__5 = jss + ir * cd_dim1;
  3925.         d__1 = segj_1.ax[i - 1] + segj_1.cx[i - 1];
  3926.         z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
  3927.         z__1.r = cd[i__5].r - z__2.r, z__1.i = cd[i__5].i - z__2.i;
  3928.         cd[i__2].r = z__1.r, cd[i__2].i = z__1.i;
  3929.         }
  3930. /*<    11 CONTINUE >*/
  3931. L11:
  3932.         ;
  3933.     }
  3934. /*     FILL B(WW)PRIME */
  3935. /*<    12 IF( NSCON.EQ.0) GOTO 20 >*/
  3936. L12:
  3937.     if (segj_1.nscon == 0) {
  3938.         goto L20;
  3939.     }
  3940. /*<       DO 19  I=1, NSCON >*/
  3941.     i__4 = segj_1.nscon;
  3942.     for (i = 1; i <= i__4; ++i) {
  3943. /*     SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS
  3944.  WHICH */
  3945. /*     CONNECT TO NEW SEGMENTS */
  3946. /*<       J= ISCON( I) >*/
  3947.         j = segj_1.iscon[i - 1];
  3948. /*<       CALL TRIO( J) >*/
  3949.         trio_(&j);
  3950. /*<       JSS=0 >*/
  3951.         jss = 0;
  3952. /*<       DO 15  IX=1, JSNO >*/
  3953.         i__2 = segj_1.jsno;
  3954.         for (ix = 1; ix <= i__2; ++ix) {
  3955. /*<       IR= JCO( IX) >*/
  3956.         ir = segj_1.jco[ix - 1];
  3957. /*<       IF( IR.LT. N2) GOTO 13 >*/
  3958.         if (ir < data_1.n2) {
  3959.             goto L13;
  3960.         }
  3961. /*<       IR= IR- N1 >*/
  3962.         ir -= data_1.n1;
  3963. /*<       GOTO 14 >*/
  3964.         goto L14;
  3965. /*<    13 IR= ICONX( IR) >*/
  3966. L13:
  3967.         ir = data_1.iconx[ir - 1];
  3968. /*<       IF( IR.EQ.0) GOTO 15 >*/
  3969.         if (ir == 0) {
  3970.             goto L15;
  3971.         }
  3972. /*<       IR= NEQS+ IR >*/
  3973.         ir = neqs + ir;
  3974. /*<    14 JSS= JSS+1 >*/
  3975. L14:
  3976.         ++jss;
  3977. /*<       JCO( JSS)= IR >*/
  3978.         segj_1.jco[jss - 1] = ir;
  3979. /*<       AX( JSS)= AX( IX) >*/
  3980.         segj_1.ax[jss - 1] = segj_1.ax[ix - 1];
  3981. /*<       BX( JSS)= BX( IX) >*/
  3982.         segj_1.bx[jss - 1] = segj_1.bx[ix - 1];
  3983. /*<       CX( JSS)= CX( IX) >*/
  3984.         segj_1.cx[jss - 1] = segj_1.cx[ix - 1];
  3985. /*<    15 CONTINUE >*/
  3986. L15:
  3987.         ;
  3988.         }
  3989. /*<       JSNO= JSS >*/
  3990.         segj_1.jsno = jss;
  3991. /*<       IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0) >*/
  3992.         if (i1 <= in2) {
  3993.         cmww_(&j, &i1, &in2, &cb[cb_offset], nb, &cb[cb_offset], nb, &
  3994.             c__0);
  3995.         }
  3996. /*     SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART 
  3997. OF */
  3998. /*     MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A 
  3999. NEW */
  4000. /*     SEGMENT ON END OPPOSITE PATCH. */
  4001. /*<    >*/
  4002.         if (im1 <= im2) {
  4003.         cmws_(&j, &im1, &im2, &cb[imx + cb_dim1], nb, &cb[cb_offset], 
  4004.             nb, &c__0);
  4005.         }
  4006. /*<       IF( I1.LE. IN2) CALL CMSW( J, I, I1, IN2, CB, CB,0, NB,-1) >*/
  4007.         if (i1 <= in2) {
  4008.         cmsw_(&j, &i, &i1, &in2, &cb[cb_offset], &cb[cb_offset], &
  4009.             c__0, nb, &c_n1);
  4010.         }
  4011. /*<       IF( NLODF.EQ.0) GOTO 17 >*/
  4012.         if (zload_1.nlodf == 0) {
  4013.         goto L17;
  4014.         }
  4015. /*<       JX= J- ISV >*/
  4016.         jx = j - isv;
  4017. /*<       IF( JX.LT.1.OR. JX.GT. IT) GOTO 17 >*/
  4018.         if (jx < 1 || jx > it) {
  4019.         goto L17;
  4020.         }
  4021. /*<       EXK= ZARRAY( J) >*/
  4022.         i__2 = j - 1;
  4023.         dataj_1.exk.r = zload_1.zarray[i__2].r, dataj_1.exk.i = 
  4024.             zload_1.zarray[i__2].i;
  4025. /*<       DO 16  IX=1, JSNO >*/
  4026.         i__2 = segj_1.jsno;
  4027.         for (ix = 1; ix <= i__2; ++ix) {
  4028. /*<       JSS= JCO( IX) >*/
  4029.         jss = segj_1.jco[ix - 1];
  4030. /*     SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OL
  4031. D SEGMENTS */
  4032. /*     EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEG
  4033. MENTS. */
  4034. /*<    16 CB( JX, JSS)= CB( JX, JSS)-( AX( IX)+ CX( IX))* EXK >*/
  4035. /* L16: */
  4036.         i__5 = jx + jss * cb_dim1;
  4037.         i__3 = jx + jss * cb_dim1;
  4038.         d__1 = segj_1.ax[ix - 1] + segj_1.cx[ix - 1];
  4039.         z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
  4040.         z__1.r = cb[i__3].r - z__2.r, z__1.i = cb[i__3].i - z__2.i;
  4041.         cb[i__5].r = z__1.r, cb[i__5].i = z__1.i;
  4042.         }
  4043. /*<    17 CALL TBF( J,1) >*/
  4044. L17:
  4045.         tbf_(&j, &c__1);
  4046. /*<       JSX= JSNO >*/
  4047.         jsx = segj_1.jsno;
  4048. /*<       JSNO=1 >*/
  4049.         segj_1.jsno = 1;
  4050. /*<       IR= JCO(1) >*/
  4051.         ir = segj_1.jco[0];
  4052. /*<       JCO(1)= NEQS+ I >*/
  4053.         segj_1.jco[0] = neqs + i;
  4054. /*<       DO 19  IX=1, JSX >*/
  4055.         i__5 = jsx;
  4056.         for (ix = 1; ix <= i__5; ++ix) {
  4057. /*<       IF( IX.EQ.1) GOTO 18 >*/
  4058.         if (ix == 1) {
  4059.             goto L18;
  4060.         }
  4061. /*<       IR= JCO( IX) >*/
  4062.         ir = segj_1.jco[ix - 1];
  4063. /*<       AX(1)= AX( IX) >*/
  4064.         segj_1.ax[0] = segj_1.ax[ix - 1];
  4065. /*<       BX(1)= BX( IX) >*/
  4066.         segj_1.bx[0] = segj_1.bx[ix - 1];
  4067. /*<       CX(1)= CX( IX) >*/
  4068.         segj_1.cx[0] = segj_1.cx[ix - 1];
  4069. /*<    18 IF( IR.GT. N1) GOTO 19 >*/
  4070. L18:
  4071.         if (ir > data_1.n1) {
  4072.             goto L19;
  4073.         }
  4074. /*<       IF( ICONX( IR).NE.0) GOTO 19 >*/
  4075.         if (data_1.iconx[ir - 1] != 0) {
  4076.             goto L19;
  4077.         }
  4078. /*<       IF( I1.LE. IN2) CALL CMWW( IR, I1, IN2, CB, NB, CB, NB,0) >*/
  4079.         if (i1 <= in2) {
  4080.             cmww_(&ir, &i1, &in2, &cb[cb_offset], nb, &cb[cb_offset], 
  4081.                 nb, &c__0);
  4082.         }
  4083. /*     LOADING FOR B(WW)PRIME */
  4084. /*<    >*/
  4085.         if (im1 <= im2) {
  4086.             cmws_(&ir, &im1, &im2, &cb[imx + cb_dim1], nb, &cb[
  4087.                 cb_offset], nb, &c__0);
  4088.         }
  4089. /*<       IF( NLODF.EQ.0) GOTO 19 >*/
  4090.         if (zload_1.nlodf == 0) {
  4091.             goto L19;
  4092.         }
  4093. /*<       JX= IR- ISV >*/
  4094.         jx = ir - isv;
  4095. /*<       IF( JX.LT.1.OR. JX.GT. IT) GOTO 19 >*/
  4096.         if (jx < 1 || jx > it) {
  4097.             goto L19;
  4098.         }
  4099. /*<       EXK= ZARRAY( IR) >*/
  4100.         i__3 = ir - 1;
  4101.         dataj_1.exk.r = zload_1.zarray[i__3].r, dataj_1.exk.i = 
  4102.             zload_1.zarray[i__3].i;
  4103. /*<       JSS= JCO(1) >*/
  4104.         jss = segj_1.jco[0];
  4105. /*<       CB( JX, JSS)= CB( JX, JSS)-( AX(1)+ CX(1))* EXK >*/
  4106.         i__3 = jx + jss * cb_dim1;
  4107.         i__2 = jx + jss * cb_dim1;
  4108.         d__1 = segj_1.ax[0] + segj_1.cx[0];
  4109.         z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
  4110.         z__1.r = cb[i__2].r - z__2.r, z__1.i = cb[i__2].i - z__2.i;
  4111.         cb[i__3].r = z__1.r, cb[i__3].i = z__1.i;
  4112. /*<    19 CONTINUE >*/
  4113. L19:
  4114.         ;
  4115.         }
  4116.     }
  4117. /*<    20 IF( NPCON.EQ.0) GOTO 22 >*/
  4118. L20:
  4119.     if (segj_1.npcon == 0) {
  4120.         goto L22;
  4121.     }
  4122. /*     FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FOR */
  4123.  
  4124. /*     PATCHES THAT CONNECT TO NEW SEGMENTS */
  4125. /*<       JSS= NEQP >*/
  4126.     jss = neqp;
  4127. /*<       DO 21  I=1, NPCON >*/
  4128.     i__5 = segj_1.npcon;
  4129.     for (i = 1; i <= i__5; ++i) {
  4130. /*<       IX= IPCON( I)*2+ N1- ISV >*/
  4131.         ix = (segj_1.ipcon[i - 1] << 1) + data_1.n1 - isv;
  4132. /*<       IR= IX-1 >*/
  4133.         ir = ix - 1;
  4134. /*<       JSS= JSS+1 >*/
  4135.         ++jss;
  4136. /*<       IF( IR.GT.0.AND. IR.LE. IT) CB( IR, JSS)=(1.,0.) >*/
  4137.         if (ir > 0 && ir <= it) {
  4138.         i__4 = ir + jss * cb_dim1;
  4139.         cb[i__4].r = 1., cb[i__4].i = 0.;
  4140.         }
  4141. /*<       JSS= JSS+1 >*/
  4142.         ++jss;
  4143. /*<       IF( IX.GT.0.AND. IX.LE. IT) CB( IX, JSS)=(1.,0.) >*/
  4144.         if (ix > 0 && ix <= it) {
  4145.         i__4 = ix + jss * cb_dim1;
  4146.         cb[i__4].r = 1., cb[i__4].i = 0.;
  4147.         }
  4148. /*<    21 CONTINUE >*/
  4149. /* L21: */
  4150.     }
  4151. /*     FILL B(SW) AND B(SS) */
  4152. /*<    22 IF( M2.GT. M) GOTO 23 >*/
  4153. L22:
  4154.     if (data_1.m2 > data_1.m) {
  4155.         goto L23;
  4156.     }
  4157. /*<    >*/
  4158.     if (i1 <= in2) {
  4159.         cmsw_(&data_1.m2, &data_1.m, &i1, &in2, &cb[ist * cb_dim1 + 1], &
  4160.             cb[cb_offset], &data_1.n1, nb, &c__0);
  4161.     }
  4162. /*<    >*/
  4163.     if (im1 <= im2) {
  4164.         cmss_(&data_1.m2, &data_1.m, &im1, &im2, &cb[imx + ist * cb_dim1],
  4165.              nb, &c__0);
  4166.     }
  4167. /*<    23 IF( ICASX.EQ.1) GOTO 24 >*/
  4168. L23:
  4169.     if (matpar_1.icasx == 1) {
  4170.         goto L24;
  4171.     }
  4172. /*<       WRITE( 14) (( CB( I, J), I=1, IT), J=1, ND) >*/
  4173.     s_wsue(&io___256);
  4174.     i__5 = *nd;
  4175.     for (j = 1; j <= i__5; ++j) {
  4176.         i__4 = it;
  4177.         for (i = 1; i <= i__4; ++i) {
  4178.         do_uio(&c__2, (char *)&cb[i + j * cb_dim1], (ftnlen)sizeof(
  4179.             doublereal));
  4180.         }
  4181.     }
  4182.     e_wsue();
  4183. /*     FILLING B COMPLETE.  START ON C AND D */
  4184. /*<    24 CONTINUE >*/
  4185. L24:
  4186.     ;
  4187.     }
  4188. /*<       IT= NPBL >*/
  4189.     it = matpar_1.npbl;
  4190. /*<       ISV=- NPBL >*/
  4191.     isv = -matpar_1.npbl;
  4192. /*<       DO 43  IBLK=1, NBBL >*/
  4193.     i__1 = matpar_1.nbbl;
  4194.     for (iblk = 1; iblk <= i__1; ++iblk) {
  4195. /*<       ISV= ISV+ NPBL >*/
  4196.     isv += matpar_1.npbl;
  4197. /*<       ISVV= ISV+ NC >*/
  4198.     isvv = isv + *nc;
  4199. /*<       IF( IBLK.EQ. NBBL) IT= NLBL >*/
  4200.     if (iblk == matpar_1.nbbl) {
  4201.         it = matpar_1.nlbl;
  4202.     }
  4203. /*<       IF( ICASX.LT.3) GOTO 27 >*/
  4204.     if (matpar_1.icasx < 3) {
  4205.         goto L27;
  4206.     }
  4207. /*<       DO 26  J=1, IT >*/
  4208.     i__4 = it;
  4209.     for (j = 1; j <= i__4; ++j) {
  4210. /*<       DO 25  I=1, NC >*/
  4211.         i__5 = *nc;
  4212.         for (i = 1; i <= i__5; ++i) {
  4213. /*<    25 CC( I, J)=(0.,0.) >*/
  4214. /* L25: */
  4215.         i__3 = i + j * cc_dim1;
  4216.         cc[i__3].r = 0., cc[i__3].i = 0.;
  4217.         }
  4218. /*<       DO 26  I=1, ND >*/
  4219.         i__3 = *nd;
  4220.         for (i = 1; i <= i__3; ++i) {
  4221. /*<    26 CD( I, J)=(0.,0.) >*/
  4222. /* L26: */
  4223.         i__5 = i + j * cd_dim1;
  4224.         cd[i__5].r = 0., cd[i__5].i = 0.;
  4225.         }
  4226.     }
  4227. /*<    27 I1= ISVV+1 >*/
  4228. L27:
  4229.     i1 = isvv + 1;
  4230. /*<       I2= ISVV+ IT >*/
  4231.     i2 = isvv + it;
  4232. /*<       IN1= I1- M1EQ >*/
  4233.     in1 = i1 - m1eq;
  4234. /*<       IN2= I2- M1EQ >*/
  4235.     in2 = i2 - m1eq;
  4236. /*<       IF( IN2.GT. N) IN2= N >*/
  4237.     if (in2 > data_1.n) {
  4238.         in2 = data_1.n;
  4239.     }
  4240. /*<       IM1= I1- N >*/
  4241.     im1 = i1 - data_1.n;
  4242. /*<       IM2= I2- N >*/
  4243.     im2 = i2 - data_1.n;
  4244. /*<       IF( IM1.LT. M2EQ) IM1= M2EQ >*/
  4245.     if (im1 < m2eq) {
  4246.         im1 = m2eq;
  4247.     }
  4248. /*<       IF( IM2.GT. MEQ) IM2= MEQ >*/
  4249.     if (im2 > meq) {
  4250.         im2 = meq;
  4251.     }
  4252. /*<       IMX=1 >*/
  4253.     imx = 1;
  4254. /*<       IF( IN1.LE. IN2) IMX= NEQN- I1+2 >*/
  4255.     if (in1 <= in2) {
  4256.         imx = neqn - i1 + 2;
  4257.     }
  4258. /*<       IF( ICASX.LT.3) GOTO 32 >*/
  4259.     if (matpar_1.icasx < 3) {
  4260.         goto L32;
  4261.     }
  4262. /*     SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2 */
  4263. /*<       IF( N2.GT. N) GOTO 32 >*/
  4264.     if (data_1.n2 > data_1.n) {
  4265.         goto L32;
  4266.     }
  4267. /*<       DO 31  J= N2, N >*/
  4268.     i__5 = data_1.n;
  4269.     for (j = data_1.n2; j <= i__5; ++j) {
  4270. /*<       CALL TRIO( J) >*/
  4271.         trio_(&j);
  4272. /*<       DO 29  I=1, JSNO >*/
  4273.         i__3 = segj_1.jsno;
  4274.         for (i = 1; i <= i__3; ++i) {
  4275. /*<       JSS= JCO( I) >*/
  4276.         jss = segj_1.jco[i - 1];
  4277. /*<       IF( JSS.LT. N2) GOTO 28 >*/
  4278.         if (jss < data_1.n2) {
  4279.             goto L28;
  4280.         }
  4281. /*<       JCO( I)= JSS- N1 >*/
  4282.         segj_1.jco[i - 1] = jss - data_1.n1;
  4283. /*<       GOTO 29 >*/
  4284.         goto L29;
  4285. /*<    28 JCO( I)= NEQS+ ICONX( JSS) >*/
  4286. L28:
  4287.         segj_1.jco[i - 1] = neqs + data_1.iconx[jss - 1];
  4288. /*<    29 CONTINUE >*/
  4289. L29:
  4290.         ;
  4291.         }
  4292. /*<       IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CD, ND, CD, ND,1) >*/
  4293.         if (in1 <= in2) {
  4294.         cmww_(&j, &in1, &in2, &cd[cd_offset], nd, &cd[cd_offset], nd, 
  4295.             &c__1);
  4296.         }
  4297. /*<    >*/
  4298.         if (im1 <= im2) {
  4299.         cmws_(&j, &im1, &im2, &cd[imx * cd_dim1 + 1], nd, &cd[
  4300.             cd_offset], nd, &c__1);
  4301.         }
  4302. /*<       IF( NLOAD.EQ.0) GOTO 31 >*/
  4303.         if (zload_1.nload == 0) {
  4304.         goto L31;
  4305.         }
  4306. /*<       IR= J- N1- ISV >*/
  4307.         ir = j - data_1.n1 - isv;
  4308. /*<       IF( IR.LT.1.OR. IR.GT. IT) GOTO 31 >*/
  4309.         if (ir < 1 || ir > it) {
  4310.         goto L31;
  4311.         }
  4312. /*<       EXK= ZARRAY( J) >*/
  4313.         i__3 = j - 1;
  4314.         dataj_1.exk.r = zload_1.zarray[i__3].r, dataj_1.exk.i = 
  4315.             zload_1.zarray[i__3].i;
  4316. /*<       DO 30  I=1, JSNO >*/
  4317.         i__3 = segj_1.jsno;
  4318.         for (i = 1; i <= i__3; ++i) {
  4319. /*<       JSS= JCO( I) >*/
  4320.         jss = segj_1.jco[i - 1];
  4321. /*<    30 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK >*/
  4322. /* L30: */
  4323.         i__4 = jss + ir * cd_dim1;
  4324.         i__2 = jss + ir * cd_dim1;
  4325.         d__1 = segj_1.ax[i - 1] + segj_1.cx[i - 1];
  4326.         z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
  4327.         z__1.r = cd[i__2].r - z__2.r, z__1.i = cd[i__2].i - z__2.i;
  4328.         cd[i__4].r = z__1.r, cd[i__4].i = z__1.i;
  4329.         }
  4330. /*<    31 CONTINUE >*/
  4331. L31:
  4332.         ;
  4333.     }
  4334. /*     FILL D(SW) AND D(SS) */
  4335. /*<    32 IF( M2.GT. M) GOTO 33 >*/
  4336. L32:
  4337.     if (data_1.m2 > data_1.m) {
  4338.         goto L33;
  4339.     }
  4340. /*<    >*/
  4341.     if (in1 <= in2) {
  4342.         cmsw_(&data_1.m2, &data_1.m, &in1, &in2, &cd[ist + cd_dim1], &cd[
  4343.             cd_offset], &data_1.n1, nd, &c__1);
  4344.     }
  4345. /*<    >*/
  4346.     if (im1 <= im2) {
  4347.         cmss_(&data_1.m2, &data_1.m, &im1, &im2, &cd[ist + imx * cd_dim1],
  4348.              nd, &c__1);
  4349.     }
  4350. /*     FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME. */
  4351. /*<    33 IF( N1.LT.1) GOTO 39 >*/
  4352. L33:
  4353.     if (data_1.n1 < 1) {
  4354.         goto L39;
  4355.     }
  4356. /*<       DO 37  J=1, N1 >*/
  4357.     i__5 = data_1.n1;
  4358.     for (j = 1; j <= i__5; ++j) {
  4359. /*<       CALL TRIO( J) >*/
  4360.         trio_(&j);
  4361. /*<       IF( NSCON.EQ.0) GOTO 36 >*/
  4362.         if (segj_1.nscon == 0) {
  4363.         goto L36;
  4364.         }
  4365. /*<       DO 35  IX=1, JSNO >*/
  4366.         i__4 = segj_1.jsno;
  4367.         for (ix = 1; ix <= i__4; ++ix) {
  4368. /*<       JSS= JCO( IX) >*/
  4369.         jss = segj_1.jco[ix - 1];
  4370. /*<       IF( JSS.LT. N2) GOTO 34 >*/
  4371.         if (jss < data_1.n2) {
  4372.             goto L34;
  4373.         }
  4374. /*<       JCO( IX)= JSS+ M1EQ >*/
  4375.         segj_1.jco[ix - 1] = jss + m1eq;
  4376. /*<       GOTO 35 >*/
  4377.         goto L35;
  4378. /*<    34 IR= ICONX( JSS) >*/
  4379. L34:
  4380.         ir = data_1.iconx[jss - 1];
  4381. /*<       IF( IR.NE.0) JCO( IX)= NEQSP+ IR >*/
  4382.         if (ir != 0) {
  4383.             segj_1.jco[ix - 1] = neqsp + ir;
  4384.         }
  4385. /*<    35 CONTINUE >*/
  4386. L35:
  4387.         ;
  4388.         }
  4389. /*<    36 IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CC, NC, CD, ND, ITX) >*/
  4390. L36:
  4391.         if (in1 <= in2) {
  4392.         cmww_(&j, &in1, &in2, &cc[cc_offset], nc, &cd[cd_offset], nd, 
  4393.             &itx);
  4394.         }
  4395. /*<    >*/
  4396.         if (im1 <= im2) {
  4397.         cmws_(&j, &im1, &im2, &cc[imx * cc_dim1 + 1], nc, &cd[imx * 
  4398.             cd_dim1 + 1], nd, &itx);
  4399.         }
  4400. /*<    37 CONTINUE >*/
  4401. /* L37: */
  4402.     }
  4403. /*     FILL C(WW)PRIME */
  4404. /*<       IF( NSCON.EQ.0) GOTO 39 >*/
  4405.     if (segj_1.nscon == 0) {
  4406.         goto L39;
  4407.     }
  4408. /*<       DO 38  IX=1, NSCON >*/
  4409.     i__5 = segj_1.nscon;
  4410.     for (ix = 1; ix <= i__5; ++ix) {
  4411. /*<       IR= ISCON( IX) >*/
  4412.         ir = segj_1.iscon[ix - 1];
  4413. /*<       JSS= NEQS+ IX- ISV >*/
  4414.         jss = neqs + ix - isv;
  4415. /*<       IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.) >*/
  4416.         if (jss > 0 && jss <= it) {
  4417.         i__4 = ir + jss * cc_dim1;
  4418.         cc[i__4].r = 1., cc[i__4].i = 0.;
  4419.         }
  4420. /*<    38 CONTINUE >*/
  4421. /* L38: */
  4422.     }
  4423. /*<    39 IF( NPCON.EQ.0) GOTO 41 >*/
  4424. L39:
  4425.     if (segj_1.npcon == 0) {
  4426.         goto L41;
  4427.     }
  4428. /*     FILL C(SS)PRIME */
  4429. /*<       JSS= NEQP- ISV >*/
  4430.     jss = neqp - isv;
  4431. /*<       DO 40  I=1, NPCON >*/
  4432.     i__5 = segj_1.npcon;
  4433.     for (i = 1; i <= i__5; ++i) {
  4434. /*<       IX= IPCON( I)*2+ N1 >*/
  4435.         ix = (segj_1.ipcon[i - 1] << 1) + data_1.n1;
  4436. /*<       IR= IX-1 >*/
  4437.         ir = ix - 1;
  4438. /*<       JSS= JSS+1 >*/
  4439.         ++jss;
  4440. /*<       IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.) >*/
  4441.         if (jss > 0 && jss <= it) {
  4442.         i__4 = ir + jss * cc_dim1;
  4443.         cc[i__4].r = 1., cc[i__4].i = 0.;
  4444.         }
  4445. /*<       JSS= JSS+1 >*/
  4446.         ++jss;
  4447. /*<       IF( JSS.GT.0.AND. JSS.LE. IT) CC( IX, JSS)=(1.,0.) >*/
  4448.         if (jss > 0 && jss <= it) {
  4449.         i__4 = ix + jss * cc_dim1;
  4450.         cc[i__4].r = 1., cc[i__4].i = 0.;
  4451.         }
  4452. /*<    40 CONTINUE >*/
  4453. /* L40: */
  4454.     }
  4455. /*     FILL C(SW) AND C(SS) */
  4456. /*<    41 IF( M1.LT.1) GOTO 42 >*/
  4457. L41:
  4458.     if (data_1.m1 < 1) {
  4459.         goto L42;
  4460.     }
  4461. /*<    >*/
  4462.     if (in1 <= in2) {
  4463.         cmsw_(&c__1, &data_1.m1, &in1, &in2, &cc[data_1.n2 + cc_dim1], &
  4464.             cc[cc_offset], &c__0, nc, &c__1);
  4465.     }
  4466. /*<       IF( IM1.LE. IM2) CALL CMSS(1, M1, IM1, IM2, CC( N2, IMX), NC,1) >*/
  4467.     if (im1 <= im2) {
  4468.         cmss_(&c__1, &data_1.m1, &im1, &im2, &cc[data_1.n2 + imx * 
  4469.             cc_dim1], nc, &c__1);
  4470.     }
  4471. /*<    42 CONTINUE >*/
  4472. L42:
  4473. /*<       IF( ICASX.EQ.1) GOTO 43 >*/
  4474.     if (matpar_1.icasx == 1) {
  4475.         goto L43;
  4476.     }
  4477. /*<       WRITE( 12) (( CD( J, I), J=1, ND), I=1, IT) >*/
  4478.     s_wsue(&io___259);
  4479.     i__5 = it;
  4480.     for (i = 1; i <= i__5; ++i) {
  4481.         i__4 = *nd;
  4482.         for (j = 1; j <= i__4; ++j) {
  4483.         do_uio(&c__2, (char *)&cd[j + i * cd_dim1], (ftnlen)sizeof(
  4484.             doublereal));
  4485.         }
  4486.     }
  4487.     e_wsue();
  4488. /*<       WRITE( 15) (( CC( J, I), J=1, NC), I=1, IT) >*/
  4489.     s_wsue(&io___260);
  4490.     i__4 = it;
  4491.     for (i = 1; i <= i__4; ++i) {
  4492.         i__5 = *nc;
  4493.         for (j = 1; j <= i__5; ++j) {
  4494.         do_uio(&c__2, (char *)&cc[j + i * cc_dim1], (ftnlen)sizeof(
  4495.             doublereal));
  4496.         }
  4497.     }
  4498.     e_wsue();
  4499. /*<    43 CONTINUE >*/
  4500. L43:
  4501.     ;
  4502.     }
  4503. /*<       IF( ICASX.EQ.1) RETURN >*/
  4504.     if (matpar_1.icasx == 1) {
  4505.     return 0;
  4506.     }
  4507. /*<       REWIND 12 >*/
  4508.     al__1.aerr = 0;
  4509.     al__1.aunit = 12;
  4510.     f_rew(&al__1);
  4511. /*<       REWIND 14 >*/
  4512.     al__1.aerr = 0;
  4513.     al__1.aunit = 14;
  4514.     f_rew(&al__1);
  4515. /*<       REWIND 15 >*/
  4516.     al__1.aerr = 0;
  4517.     al__1.aunit = 15;
  4518.     f_rew(&al__1);
  4519. /*<       RETURN >*/
  4520.     return 0;
  4521. /*<       END >*/
  4522. } /* cmngf_ */
  4523.  
  4524. /* *** */
  4525. /*     DOUBLE PRECISION 6/4/85 */
  4526.  
  4527. /*<       SUBROUTINE CMSET( NROW, CM, RKHX, IEXKX) >*/
  4528. /* Subroutine */ int cmset_(nrow, cm, rkhx, iexkx)
  4529. integer *nrow;
  4530. doublecomplex *cm;
  4531. doublereal *rkhx;
  4532. integer *iexkx;
  4533. {
  4534.     /* System generated locals */
  4535.     integer cm_dim1, cm_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
  4536.     doublereal d__1;
  4537.     doublecomplex z__1, z__2;
  4538.     alist al__1;
  4539.  
  4540.     /* Builtin functions */
  4541.     integer f_rew();
  4542.  
  4543.     /* Local variables */
  4544.     static integer npeq;
  4545.     extern /* Subroutine */ int cmss_(), cmws_(), cmsw_(), trio_(), cmww_();
  4546.     static integer iout, i, j, k;
  4547.     static doublecomplex deter;
  4548.     static integer i1, i2, ixblk1, ka, ij, kk, it;
  4549.     extern /* Subroutine */ int blckot_();
  4550.     static integer im1, in2, im2, jm1, jm2, mp2;
  4551.     static doublecomplex zaj;
  4552.     static integer neq, ipr, nop, isv, ist, jss, jst;
  4553.  
  4554. /* *** */
  4555. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  4556.  
  4557. /*     CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM */
  4558.  
  4559. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  4560. /*<    >*/
  4561. /*<    >*/
  4562. /*<    >*/
  4563. /*<       COMMON  /SMAT/ SSX(16,16) >*/
  4564. /*<       COMMON  /SCRATM/ D( N2M) >*/
  4565. /*<       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
  4566. /*<    >*/
  4567. /*<    >*/
  4568. /*<       DIMENSION  CM( NROW,1) >*/
  4569. /*<       MP2=2* MP >*/
  4570.     /* Parameter adjustments */
  4571.     cm_dim1 = *nrow;
  4572.     cm_offset = cm_dim1 + 1;
  4573.     cm -= cm_offset;
  4574.  
  4575.     /* Function Body */
  4576.     mp2 = data_1.mp << 1;
  4577. /*<       NPEQ= NP+ MP2 >*/
  4578.     npeq = data_1.np + mp2;
  4579. /*<       NEQ= N+2* M >*/
  4580.     neq = data_1.n + (data_1.m << 1);
  4581. /*<       NOP= NEQ/ NPEQ >*/
  4582.     nop = neq / npeq;
  4583. /*<       IF( ICASE.GT.2) REWIND 11 >*/
  4584.     if (matpar_1.icase > 2) {
  4585.     al__1.aerr = 0;
  4586.     al__1.aunit = 11;
  4587.     f_rew(&al__1);
  4588.     }
  4589. /*<       RKH= RKHX >*/
  4590.     dataj_1.rkh = *rkhx;
  4591. /*<       IEXK= IEXKX >*/
  4592.     dataj_1.iexk = *iexkx;
  4593. /*<       IOUT=2* NPBLK* NROW >*/
  4594.     iout = (matpar_1.npblk << 1) * *nrow;
  4595.  
  4596. /*     CYCLE OVER MATRIX BLOCKS */
  4597.  
  4598. /*<       IT= NPBLK >*/
  4599.     it = matpar_1.npblk;
  4600. /*<       DO 13  IXBLK1=1, NBLOKS >*/
  4601.     i__1 = matpar_1.nbloks;
  4602.     for (ixblk1 = 1; ixblk1 <= i__1; ++ixblk1) {
  4603. /*<       ISV=( IXBLK1-1)* NPBLK >*/
  4604.     isv = (ixblk1 - 1) * matpar_1.npblk;
  4605. /*<       IF( IXBLK1.EQ. NBLOKS) IT= NLAST >*/
  4606.     if (ixblk1 == matpar_1.nbloks) {
  4607.         it = matpar_1.nlast;
  4608.     }
  4609. /*<       DO 1  I=1, NROW >*/
  4610.     i__2 = *nrow;
  4611.     for (i = 1; i <= i__2; ++i) {
  4612. /*<       DO 1  J=1, IT >*/
  4613.         i__3 = it;
  4614.         for (j = 1; j <= i__3; ++j) {
  4615. /*<     1 CM( I, J)=(0.,0.) >*/
  4616. /* L1: */
  4617.         i__4 = i + j * cm_dim1;
  4618.         cm[i__4].r = 0., cm[i__4].i = 0.;
  4619.         }
  4620.     }
  4621. /*<       I1= ISV+1 >*/
  4622.     i1 = isv + 1;
  4623. /*<       I2= ISV+ IT >*/
  4624.     i2 = isv + it;
  4625. /*<       IN2= I2 >*/
  4626.     in2 = i2;
  4627. /*<       IF( IN2.GT. NP) IN2= NP >*/
  4628.     if (in2 > data_1.np) {
  4629.         in2 = data_1.np;
  4630.     }
  4631. /*<       IM1= I1- NP >*/
  4632.     im1 = i1 - data_1.np;
  4633. /*<       IM2= I2- NP >*/
  4634.     im2 = i2 - data_1.np;
  4635. /*<       IF( IM1.LT.1) IM1=1 >*/
  4636.     if (im1 < 1) {
  4637.         im1 = 1;
  4638.     }
  4639. /*<       IST=1 >*/
  4640.     ist = 1;
  4641. /*<       IF( I1.LE. NP) IST= NP- I1+2 >*/
  4642.     if (i1 <= data_1.np) {
  4643.         ist = data_1.np - i1 + 2;
  4644.     }
  4645.  
  4646. /*     WIRE SOURCE LOOP */
  4647.  
  4648. /*<       IF( N.EQ.0) GOTO 5 >*/
  4649.     if (data_1.n == 0) {
  4650.         goto L5;
  4651.     }
  4652. /*<       DO 4  J=1, N >*/
  4653.     i__4 = data_1.n;
  4654.     for (j = 1; j <= i__4; ++j) {
  4655. /*<       CALL TRIO( J) >*/
  4656.         trio_(&j);
  4657. /*<       DO 2  I=1, JSNO >*/
  4658.         i__3 = segj_1.jsno;
  4659.         for (i = 1; i <= i__3; ++i) {
  4660. /*<       IJ= JCO( I) >*/
  4661.         ij = segj_1.jco[i - 1];
  4662. /*<     2 JCO( I)=(( IJ-1)/ NP)* MP2+ IJ >*/
  4663. /* L2: */
  4664.         segj_1.jco[i - 1] = (ij - 1) / data_1.np * mp2 + ij;
  4665.         }
  4666. /*<       IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CM, NROW, CM, NROW,1) >*/
  4667.         if (i1 <= in2) {
  4668.         cmww_(&j, &i1, &in2, &cm[cm_offset], nrow, &cm[cm_offset], 
  4669.             nrow, &c__1);
  4670.         }
  4671. /*<    >*/
  4672.         if (im1 <= im2) {
  4673.         cmws_(&j, &im1, &im2, &cm[ist * cm_dim1 + 1], nrow, &cm[
  4674.             cm_offset], nrow, &c__1);
  4675.         }
  4676.  
  4677. /*     MATRIX ELEMENTS MODIFIED BY LOADING */
  4678.  
  4679. /*<       IF( NLOAD.EQ.0) GOTO 4 >*/
  4680.         if (zload_1.nload == 0) {
  4681.         goto L4;
  4682.         }
  4683. /*<       IF( J.GT. NP) GOTO 4 >*/
  4684.         if (j > data_1.np) {
  4685.         goto L4;
  4686.         }
  4687. /*<       IPR= J- ISV >*/
  4688.         ipr = j - isv;
  4689. /*<       IF( IPR.LT.1.OR. IPR.GT. IT) GOTO 4 >*/
  4690.         if (ipr < 1 || ipr > it) {
  4691.         goto L4;
  4692.         }
  4693. /*<       ZAJ= ZARRAY( J) >*/
  4694.         i__3 = j - 1;
  4695.         zaj.r = zload_1.zarray[i__3].r, zaj.i = zload_1.zarray[i__3].i;
  4696. /*<       DO 3  I=1, JSNO >*/
  4697.         i__3 = segj_1.jsno;
  4698.         for (i = 1; i <= i__3; ++i) {
  4699. /*<       JSS= JCO( I) >*/
  4700.         jss = segj_1.jco[i - 1];
  4701. /*<     3 CM( JSS, IPR)= CM( JSS, IPR)-( AX( I)+ CX( I))* ZAJ >*/
  4702. /* L3: */
  4703.         i__2 = jss + ipr * cm_dim1;
  4704.         i__5 = jss + ipr * cm_dim1;
  4705.         d__1 = segj_1.ax[i - 1] + segj_1.cx[i - 1];
  4706.         z__2.r = d__1 * zaj.r, z__2.i = d__1 * zaj.i;
  4707.         z__1.r = cm[i__5].r - z__2.r, z__1.i = cm[i__5].i - z__2.i;
  4708.         cm[i__2].r = z__1.r, cm[i__2].i = z__1.i;
  4709.         }
  4710. /*<     4 CONTINUE >*/
  4711. L4:
  4712.         ;
  4713.     }
  4714. /*     MATRIX ELEMENTS FOR PATCH CURRENT SOURCES */
  4715. /*<     5 IF( M.EQ.0) GOTO 7 >*/
  4716. L5:
  4717.     if (data_1.m == 0) {
  4718.         goto L7;
  4719.     }
  4720. /*<       JM1=1- MP >*/
  4721.     jm1 = 1 - data_1.mp;
  4722. /*<       JM2=0 >*/
  4723.     jm2 = 0;
  4724. /*<       JST=1- MP2 >*/
  4725.     jst = 1 - mp2;
  4726. /*<       DO 6  I=1, NOP >*/
  4727.     i__4 = nop;
  4728.     for (i = 1; i <= i__4; ++i) {
  4729. /*<       JM1= JM1+ MP >*/
  4730.         jm1 += data_1.mp;
  4731. /*<       JM2= JM2+ MP >*/
  4732.         jm2 += data_1.mp;
  4733. /*<       JST= JST+ NPEQ >*/
  4734.         jst += npeq;
  4735. /*<    >*/
  4736.         if (i1 <= in2) {
  4737.         cmsw_(&jm1, &jm2, &i1, &in2, &cm[jst + cm_dim1], &cm[
  4738.             cm_offset], &c__0, nrow, &c__1);
  4739.         }
  4740. /*<    >*/
  4741.         if (im1 <= im2) {
  4742.         cmss_(&jm1, &jm2, &im1, &im2, &cm[jst + ist * cm_dim1], nrow, 
  4743.             &c__1);
  4744.         }
  4745. /*<     6 CONTINUE >*/
  4746. /* L6: */
  4747.     }
  4748. /*<     7 IF( ICASE.EQ.1) GOTO 13 >*/
  4749. L7:
  4750.     if (matpar_1.icase == 1) {
  4751.         goto L13;
  4752.     }
  4753. /*     COMBINE ELEMENTS FOR SYMMETRY MODES */
  4754. /*<       IF( ICASE.EQ.3) GOTO 12 >*/
  4755.     if (matpar_1.icase == 3) {
  4756.         goto L12;
  4757.     }
  4758. /*<       DO 11  I=1, IT >*/
  4759.     i__4 = it;
  4760.     for (i = 1; i <= i__4; ++i) {
  4761. /*<       DO 11  J=1, NPEQ >*/
  4762.         i__2 = npeq;
  4763.         for (j = 1; j <= i__2; ++j) {
  4764. /*<       DO 8  K=1, NOP >*/
  4765.         i__5 = nop;
  4766.         for (k = 1; k <= i__5; ++k) {
  4767. /*<       KA= J+( K-1)* NPEQ >*/
  4768.             ka = j + (k - 1) * npeq;
  4769. /*<     8 D( K)= CM( KA, I) >*/
  4770. /* L8: */
  4771.             i__3 = k - 1;
  4772.             i__6 = ka + i * cm_dim1;
  4773.             scratm_1.d[i__3].r = cm[i__6].r, scratm_1.d[i__3].i = cm[
  4774.                 i__6].i;
  4775.         }
  4776. /*<       DETER= D(1) >*/
  4777.         deter.r = scratm_1.d[0].r, deter.i = scratm_1.d[0].i;
  4778. /*<       DO 9  KK=2, NOP >*/
  4779.         i__3 = nop;
  4780.         for (kk = 2; kk <= i__3; ++kk) {
  4781. /*<     9 DETER= DETER+ D( KK) >*/
  4782. /* L9: */
  4783.             i__6 = kk - 1;
  4784.             z__1.r = deter.r + scratm_1.d[i__6].r, z__1.i = deter.i + 
  4785.                 scratm_1.d[i__6].i;
  4786.             deter.r = z__1.r, deter.i = z__1.i;
  4787.         }
  4788. /*<       CM( J, I)= DETER >*/
  4789.         i__6 = j + i * cm_dim1;
  4790.         cm[i__6].r = deter.r, cm[i__6].i = deter.i;
  4791. /*<       DO 11  K=2, NOP >*/
  4792.         i__6 = nop;
  4793.         for (k = 2; k <= i__6; ++k) {
  4794. /*<       KA= J+( K-1)* NPEQ >*/
  4795.             ka = j + (k - 1) * npeq;
  4796. /*<       DETER= D(1) >*/
  4797.             deter.r = scratm_1.d[0].r, deter.i = scratm_1.d[0].i;
  4798. /*<       DO 10  KK=2, NOP >*/
  4799.             i__3 = nop;
  4800.             for (kk = 2; kk <= i__3; ++kk) {
  4801. /*<    10 DETER= DETER+ D( KK)* SSX( K, KK) >*/
  4802. /* L10: */
  4803.             i__5 = kk - 1;
  4804.             i__7 = k + (kk << 4) - 17;
  4805.             z__2.r = scratm_1.d[i__5].r * smat_1.ssx[i__7].r - 
  4806.                 scratm_1.d[i__5].i * smat_1.ssx[i__7].i, 
  4807.                 z__2.i = scratm_1.d[i__5].r * smat_1.ssx[i__7]
  4808.                 .i + scratm_1.d[i__5].i * smat_1.ssx[i__7].r;
  4809.             z__1.r = deter.r + z__2.r, z__1.i = deter.i + z__2.i;
  4810.             deter.r = z__1.r, deter.i = z__1.i;
  4811.             }
  4812. /*<       CM( KA, I)= DETER >*/
  4813.             i__5 = ka + i * cm_dim1;
  4814.             cm[i__5].r = deter.r, cm[i__5].i = deter.i;
  4815. /*<    11 CONTINUE >*/
  4816. /* L11: */
  4817.         }
  4818.         }
  4819.     }
  4820. /*     WRITE BLOCK FOR OUT-OF-CORE CASES. */
  4821. /*<       IF( ICASE.LT.3) GOTO 13 >*/
  4822.     if (matpar_1.icase < 3) {
  4823.         goto L13;
  4824.     }
  4825. /*<    12 CALL BLCKOT( CM,11,1, IOUT,1,31) >*/
  4826. L12:
  4827.     blckot_(&cm[cm_offset], &c__11, &c__1, &iout, &c__1, &c__31);
  4828. /*<    13 CONTINUE >*/
  4829. L13:
  4830.     ;
  4831.     }
  4832. /*<       IF( ICASE.GT.2) REWIND 11 >*/
  4833.     if (matpar_1.icase > 2) {
  4834.     al__1.aerr = 0;
  4835.     al__1.aunit = 11;
  4836.     f_rew(&al__1);
  4837.     }
  4838. /*<       RETURN >*/
  4839.     return 0;
  4840. /*<       END >*/
  4841. } /* cmset_ */
  4842.  
  4843. /* *** */
  4844. /*     DOUBLE PRECISION 6/4/85 */
  4845.  
  4846. /*<       SUBROUTINE CMSS( J1, J2, IM1, IM2, CM, NROW, ITRP) >*/
  4847. /* Subroutine */ int cmss_(j1, j2, im1, im2, cm, nrow, itrp)
  4848. integer *j1, *j2, *im1, *im2;
  4849. doublecomplex *cm;
  4850. integer *nrow, *itrp;
  4851. {
  4852.     /* System generated locals */
  4853.     integer cm_dim1, cm_offset, i__1, i__2, i__3;
  4854.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
  4855.  
  4856.     /* Local variables */
  4857.     static doublereal t2yi, t2zi;
  4858.     static integer i, j, icomp;
  4859.     extern /* Subroutine */ int hintg_();
  4860.     static integer i1, i2;
  4861.     static doublecomplex g11, g12, g21, g22;
  4862.     static integer il, jl;
  4863.     static doublereal xi, yi, zi;
  4864.     static integer ii1, ii2, jj1, jj2;
  4865. #define t1x ((doublereal *)&data_1 + 1800)
  4866. #define t1y ((doublereal *)&data_1 + 3000)
  4867. #define t1z ((doublereal *)&data_1 + 3600)
  4868. #define t2x ((doublereal *)&data_1 + 4201)
  4869. #define t2y ((doublereal *)&data_1 + 4601)
  4870. #define t2z ((doublereal *)&data_1 + 5001)
  4871.     static integer ldp;
  4872.     static doublereal t1xi;
  4873. #define t1xj ((doublereal *)&dataj_1 + 5)
  4874. #define t1yj ((doublereal *)&dataj_1 + 6)
  4875. #define t1zj ((doublereal *)&dataj_1 + 7)
  4876. #define t2xj ((doublereal *)&dataj_1 + 1)
  4877. #define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
  4878. #define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
  4879.     static doublereal t1yi, t1zi, t2xi;
  4880.  
  4881. /* *** */
  4882. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  4883. /*     CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS. */
  4884. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  4885. /*<    >*/
  4886. /*<    >*/
  4887. /*<       COMMON  /ANGL/ SALP( NM) >*/
  4888. /*<    >*/
  4889. /*<       DIMENSION  CM( NROW,1) >*/
  4890. /*<       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
  4891. /*<    >*/
  4892. /*<    >*/
  4893. /*<       LDP= LD+1 >*/
  4894.     /* Parameter adjustments */
  4895.     cm_dim1 = *nrow;
  4896.     cm_offset = cm_dim1 + 1;
  4897.     cm -= cm_offset;
  4898.  
  4899.     /* Function Body */
  4900.     ldp = data_1.ld + 1;
  4901. /*<       I1=( IM1+1)/2 >*/
  4902.     i1 = (*im1 + 1) / 2;
  4903. /*<       I2=( IM2+1)/2 >*/
  4904.     i2 = (*im2 + 1) / 2;
  4905. /*<       ICOMP= I1*2-3 >*/
  4906.     icomp = (i1 << 1) - 3;
  4907. /*<       II1=-1 >*/
  4908.     ii1 = -1;
  4909. /*     LOOP OVER OBSERVATION PATCHES */
  4910. /*<       IF( ICOMP+2.LT. IM1) II1=-2 >*/
  4911.     if (icomp + 2 < *im1) {
  4912.     ii1 = -2;
  4913.     }
  4914. /*<       DO 5  I= I1, I2 >*/
  4915.     i__1 = i2;
  4916.     for (i = i1; i <= i__1; ++i) {
  4917. /*<       IL= LDP- I >*/
  4918.     il = ldp - i;
  4919. /*<       ICOMP= ICOMP+2 >*/
  4920.     icomp += 2;
  4921. /*<       II1= II1+2 >*/
  4922.     ii1 += 2;
  4923. /*<       II2= II1+1 >*/
  4924.     ii2 = ii1 + 1;
  4925. /*<       T1XI= T1X( IL)* SALP( IL) >*/
  4926.     t1xi = t1x[il - 1] * angl_1.salp[il - 1];
  4927. /*<       T1YI= T1Y( IL)* SALP( IL) >*/
  4928.     t1yi = t1y[il - 1] * angl_1.salp[il - 1];
  4929. /*<       T1ZI= T1Z( IL)* SALP( IL) >*/
  4930.     t1zi = t1z[il - 1] * angl_1.salp[il - 1];
  4931. /*<       T2XI= T2X( IL)* SALP( IL) >*/
  4932.     t2xi = t2x[il - 1] * angl_1.salp[il - 1];
  4933. /*<       T2YI= T2Y( IL)* SALP( IL) >*/
  4934.     t2yi = t2y[il - 1] * angl_1.salp[il - 1];
  4935. /*<       T2ZI= T2Z( IL)* SALP( IL) >*/
  4936.     t2zi = t2z[il - 1] * angl_1.salp[il - 1];
  4937. /*<       XI= X( IL) >*/
  4938.     xi = data_1.x[il - 1];
  4939. /*<       YI= Y( IL) >*/
  4940.     yi = data_1.y[il - 1];
  4941. /*<       ZI= Z( IL) >*/
  4942.     zi = data_1.z[il - 1];
  4943. /*     LOOP OVER SOURCE PATCHES */
  4944. /*<       JJ1=-1 >*/
  4945.     jj1 = -1;
  4946. /*<       DO 5  J= J1, J2 >*/
  4947.     i__2 = *j2;
  4948.     for (j = *j1; j <= i__2; ++j) {
  4949. /*<       JL= LDP- J >*/
  4950.         jl = ldp - j;
  4951. /*<       JJ1= JJ1+2 >*/
  4952.         jj1 += 2;
  4953. /*<       JJ2= JJ1+1 >*/
  4954.         jj2 = jj1 + 1;
  4955. /*<       S= BI( JL) >*/
  4956.         dataj_1.s = data_1.bi[jl - 1];
  4957. /*<       XJ= X( JL) >*/
  4958.         dataj_1.xj = data_1.x[jl - 1];
  4959. /*<       YJ= Y( JL) >*/
  4960.         dataj_1.yj = data_1.y[jl - 1];
  4961. /*<       ZJ= Z( JL) >*/
  4962.         dataj_1.zj = data_1.z[jl - 1];
  4963. /*<       T1XJ= T1X( JL) >*/
  4964.         *t1xj = t1x[jl - 1];
  4965. /*<       T1YJ= T1Y( JL) >*/
  4966.         *t1yj = t1y[jl - 1];
  4967. /*<       T1ZJ= T1Z( JL) >*/
  4968.         *t1zj = t1z[jl - 1];
  4969. /*<       T2XJ= T2X( JL) >*/
  4970.         *t2xj = t2x[jl - 1];
  4971. /*<       T2YJ= T2Y( JL) >*/
  4972.         *t2yj = t2y[jl - 1];
  4973. /*<       T2ZJ= T2Z( JL) >*/
  4974.         *t2zj = t2z[jl - 1];
  4975. /*<       CALL HINTG( XI, YI, ZI) >*/
  4976.         hintg_(&xi, &yi, &zi);
  4977. /*<       G11=-( T2XI* EXK+ T2YI* EYK+ T2ZI* EZK) >*/
  4978.         z__4.r = t2xi * dataj_1.exk.r, z__4.i = t2xi * dataj_1.exk.i;
  4979.         z__5.r = t2yi * dataj_1.eyk.r, z__5.i = t2yi * dataj_1.eyk.i;
  4980.         z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  4981.         z__6.r = t2zi * dataj_1.ezk.r, z__6.i = t2zi * dataj_1.ezk.i;
  4982.         z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  4983.         z__1.r = -z__2.r, z__1.i = -z__2.i;
  4984.         g11.r = z__1.r, g11.i = z__1.i;
  4985. /*<       G12=-( T2XI* EXS+ T2YI* EYS+ T2ZI* EZS) >*/
  4986.         z__4.r = t2xi * dataj_1.exs.r, z__4.i = t2xi * dataj_1.exs.i;
  4987.         z__5.r = t2yi * dataj_1.eys.r, z__5.i = t2yi * dataj_1.eys.i;
  4988.         z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  4989.         z__6.r = t2zi * dataj_1.ezs.r, z__6.i = t2zi * dataj_1.ezs.i;
  4990.         z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  4991.         z__1.r = -z__2.r, z__1.i = -z__2.i;
  4992.         g12.r = z__1.r, g12.i = z__1.i;
  4993. /*<       G21=-( T1XI* EXK+ T1YI* EYK+ T1ZI* EZK) >*/
  4994.         z__4.r = t1xi * dataj_1.exk.r, z__4.i = t1xi * dataj_1.exk.i;
  4995.         z__5.r = t1yi * dataj_1.eyk.r, z__5.i = t1yi * dataj_1.eyk.i;
  4996.         z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  4997.         z__6.r = t1zi * dataj_1.ezk.r, z__6.i = t1zi * dataj_1.ezk.i;
  4998.         z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  4999.         z__1.r = -z__2.r, z__1.i = -z__2.i;
  5000.         g21.r = z__1.r, g21.i = z__1.i;
  5001. /*<       G22=-( T1XI* EXS+ T1YI* EYS+ T1ZI* EZS) >*/
  5002.         z__4.r = t1xi * dataj_1.exs.r, z__4.i = t1xi * dataj_1.exs.i;
  5003.         z__5.r = t1yi * dataj_1.eys.r, z__5.i = t1yi * dataj_1.eys.i;
  5004.         z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  5005.         z__6.r = t1zi * dataj_1.ezs.r, z__6.i = t1zi * dataj_1.ezs.i;
  5006.         z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  5007.         z__1.r = -z__2.r, z__1.i = -z__2.i;
  5008.         g22.r = z__1.r, g22.i = z__1.i;
  5009. /*<       IF( I.NE. J) GOTO 1 >*/
  5010.         if (i != j) {
  5011.         goto L1;
  5012.         }
  5013. /*<       G11= G11-.5 >*/
  5014.         z__1.r = g11.r - .5, z__1.i = g11.i;
  5015.         g11.r = z__1.r, g11.i = z__1.i;
  5016. /*<       G22= G22+.5 >*/
  5017.         z__1.r = g22.r + .5, z__1.i = g22.i;
  5018.         g22.r = z__1.r, g22.i = z__1.i;
  5019. /*     NORMAL FILL */
  5020. /*<     1 IF( ITRP.NE.0) GOTO 3 >*/
  5021. L1:
  5022.         if (*itrp != 0) {
  5023.         goto L3;
  5024.         }
  5025. /*<       IF( ICOMP.LT. IM1) GOTO 2 >*/
  5026.         if (icomp < *im1) {
  5027.         goto L2;
  5028.         }
  5029. /*<       CM( II1, JJ1)= G11 >*/
  5030.         i__3 = ii1 + jj1 * cm_dim1;
  5031.         cm[i__3].r = g11.r, cm[i__3].i = g11.i;
  5032. /*<       CM( II1, JJ2)= G12 >*/
  5033.         i__3 = ii1 + jj2 * cm_dim1;
  5034.         cm[i__3].r = g12.r, cm[i__3].i = g12.i;
  5035. /*<     2 IF( ICOMP.GE. IM2) GOTO 5 >*/
  5036. L2:
  5037.         if (icomp >= *im2) {
  5038.         goto L5;
  5039.         }
  5040. /*<       CM( II2, JJ1)= G21 >*/
  5041.         i__3 = ii2 + jj1 * cm_dim1;
  5042.         cm[i__3].r = g21.r, cm[i__3].i = g21.i;
  5043. /*<       CM( II2, JJ2)= G22 >*/
  5044.         i__3 = ii2 + jj2 * cm_dim1;
  5045.         cm[i__3].r = g22.r, cm[i__3].i = g22.i;
  5046. /*     TRANSPOSED FILL */
  5047. /*<       GOTO 5 >*/
  5048.         goto L5;
  5049. /*<     3 IF( ICOMP.LT. IM1) GOTO 4 >*/
  5050. L3:
  5051.         if (icomp < *im1) {
  5052.         goto L4;
  5053.         }
  5054. /*<       CM( JJ1, II1)= G11 >*/
  5055.         i__3 = jj1 + ii1 * cm_dim1;
  5056.         cm[i__3].r = g11.r, cm[i__3].i = g11.i;
  5057. /*<       CM( JJ2, II1)= G12 >*/
  5058.         i__3 = jj2 + ii1 * cm_dim1;
  5059.         cm[i__3].r = g12.r, cm[i__3].i = g12.i;
  5060. /*<     4 IF( ICOMP.GE. IM2) GOTO 5 >*/
  5061. L4:
  5062.         if (icomp >= *im2) {
  5063.         goto L5;
  5064.         }
  5065. /*<       CM( JJ1, II2)= G21 >*/
  5066.         i__3 = jj1 + ii2 * cm_dim1;
  5067.         cm[i__3].r = g21.r, cm[i__3].i = g21.i;
  5068. /*<       CM( JJ2, II2)= G22 >*/
  5069.         i__3 = jj2 + ii2 * cm_dim1;
  5070.         cm[i__3].r = g22.r, cm[i__3].i = g22.i;
  5071. /*<     5 CONTINUE >*/
  5072. L5:
  5073.         ;
  5074.     }
  5075.     }
  5076. /*<       RETURN >*/
  5077.     return 0;
  5078. /*<       END >*/
  5079. } /* cmss_ */
  5080.  
  5081. #undef t2zj
  5082. #undef t2yj
  5083. #undef t2xj
  5084. #undef t1zj
  5085. #undef t1yj
  5086. #undef t1xj
  5087. #undef t2z
  5088. #undef t2y
  5089. #undef t2x
  5090. #undef t1z
  5091. #undef t1y
  5092. #undef t1x
  5093.  
  5094.  
  5095. /* *** */
  5096. /*     DOUBLE PRECISION 6/4/85 */
  5097.  
  5098. /*<       SUBROUTINE CMSW( J1, J2, I1, I2, CM, CW, NCW, NROW, ITRP) >*/
  5099. /* Subroutine */ int cmsw_(j1, j2, i1, i2, cm, cw, ncw, nrow, itrp)
  5100. integer *j1, *j2, *i1, *i2;
  5101. doublecomplex *cm, *cw;
  5102. integer *ncw, *nrow, *itrp;
  5103. {
  5104.     /* Initialized data */
  5105.  
  5106.     static doublereal pi = 3.141592654;
  5107.  
  5108.     /* System generated locals */
  5109.     integer cm_dim1, cm_offset, cw_dim1, cw_offset, i__1, i__2, i__3, i__4, 
  5110.         i__5;
  5111.     doublereal d__1, d__2;
  5112.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
  5113.  
  5114.     /* Builtin functions */
  5115.     double sin(), cos();
  5116.  
  5117.     /* Local variables */
  5118.     static doublereal sabi;
  5119.     static doublecomplex emel[9];
  5120.     static integer icgo, ipch, neqs;
  5121.     extern /* Subroutine */ int trio_();
  5122.     static integer i, j, k;
  5123.     static doublereal fsign, salpi;
  5124.     extern /* Subroutine */ int pcint_(), unere_();
  5125.     static integer il, jl;
  5126.     static doublereal xi, yi, zi;
  5127.     static integer js, ip;
  5128.     static doublereal py, px;
  5129. #define t1x ((doublereal *)&data_1 + 1800)
  5130. #define t1y ((doublereal *)&data_1 + 3000)
  5131. #define t1z ((doublereal *)&data_1 + 3600)
  5132. #define t2x ((doublereal *)&data_1 + 4201)
  5133. #define t2y ((doublereal *)&data_1 + 4601)
  5134. #define t2z ((doublereal *)&data_1 + 5001)
  5135. #define cab ((doublereal *)&data_1 + 3000)
  5136. #define sab ((doublereal *)&data_1 + 3600)
  5137.     static integer ldp;
  5138. #define t1xj ((doublereal *)&dataj_1 + 5)
  5139. #define t1yj ((doublereal *)&dataj_1 + 6)
  5140. #define t1zj ((doublereal *)&dataj_1 + 7)
  5141. #define t2xj ((doublereal *)&dataj_1 + 1)
  5142. #define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
  5143. #define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
  5144.     static doublereal cabi;
  5145.  
  5146. /* *** */
  5147. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  5148. /*     COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT */
  5149. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  5150. /*<    >*/
  5151. /*<    >*/
  5152. /*<       COMMON  /ANGL/ SALP( NM) >*/
  5153. /*<    >*/
  5154. /*<    >*/
  5155. /*<    >*/
  5156. /*<       DIMENSION  CAB(1), SAB(1), CM( NROW,1), CW( NROW,1) >*/
  5157. /*<    >*/
  5158. /*<    >*/
  5159. /*<    >*/
  5160. /*<       DATA   PI/3.141592654D+0/ >*/
  5161.     /* Parameter adjustments */
  5162.     cw_dim1 = *nrow;
  5163.     cw_offset = cw_dim1 + 1;
  5164.     cw -= cw_offset;
  5165.     cm_dim1 = *nrow;
  5166.     cm_offset = cm_dim1 + 1;
  5167.     cm -= cm_offset;
  5168.  
  5169.     /* Function Body */
  5170. /*<       LDP= LD+1 >*/
  5171.     ldp = data_1.ld + 1;
  5172. /*<       NEQS= N- N1+2*( M- M1) >*/
  5173.     neqs = data_1.n - data_1.n1 + (data_1.m - data_1.m1 << 1);
  5174. /*<       IF( ITRP.LT.0) GOTO 13 >*/
  5175.     if (*itrp < 0) {
  5176.     goto L13;
  5177.     }
  5178. /*<       K=0 >*/
  5179.     k = 0;
  5180. /*     OBSERVATION LOOP */
  5181. /*<       ICGO=1 >*/
  5182.     icgo = 1;
  5183. /*<       DO 12  I= I1, I2 >*/
  5184.     i__1 = *i2;
  5185.     for (i = *i1; i <= i__1; ++i) {
  5186. /*<       K= K+1 >*/
  5187.     ++k;
  5188. /*<       XI= X( I) >*/
  5189.     xi = data_1.x[i - 1];
  5190. /*<       YI= Y( I) >*/
  5191.     yi = data_1.y[i - 1];
  5192. /*<       ZI= Z( I) >*/
  5193.     zi = data_1.z[i - 1];
  5194. /*<       CABI= CAB( I) >*/
  5195.     cabi = cab[i - 1];
  5196. /*<       SABI= SAB( I) >*/
  5197.     sabi = sab[i - 1];
  5198. /*<       SALPI= SALP( I) >*/
  5199.     salpi = angl_1.salp[i - 1];
  5200. /*<       IPCH=0 >*/
  5201.     ipch = 0;
  5202. /*<       IF( ICON1( I).LT.10000) GOTO 1 >*/
  5203.     if (data_1.icon1[i - 1] < 10000) {
  5204.         goto L1;
  5205.     }
  5206. /*<       IPCH= ICON1( I)-10000 >*/
  5207.     ipch = data_1.icon1[i - 1] - 10000;
  5208. /*<       FSIGN=-1. >*/
  5209.     fsign = -1.;
  5210. /*<     1 IF( ICON2( I).LT.10000) GOTO 2 >*/
  5211. L1:
  5212.     if (data_1.icon2[i - 1] < 10000) {
  5213.         goto L2;
  5214.     }
  5215. /*<       IPCH= ICON2( I)-10000 >*/
  5216.     ipch = data_1.icon2[i - 1] - 10000;
  5217. /*<       FSIGN=1. >*/
  5218.     fsign = 1.;
  5219. /*     SOURCE LOOP */
  5220. /*<     2 JL=0 >*/
  5221. L2:
  5222.     jl = 0;
  5223. /*<       DO 12  J= J1, J2 >*/
  5224.     i__2 = *j2;
  5225.     for (j = *j1; j <= i__2; ++j) {
  5226. /*<       JS= LDP- J >*/
  5227.         js = ldp - j;
  5228. /*<       JL= JL+2 >*/
  5229.         jl += 2;
  5230. /*<       T1XJ= T1X( JS) >*/
  5231.         *t1xj = t1x[js - 1];
  5232. /*<       T1YJ= T1Y( JS) >*/
  5233.         *t1yj = t1y[js - 1];
  5234. /*<       T1ZJ= T1Z( JS) >*/
  5235.         *t1zj = t1z[js - 1];
  5236. /*<       T2XJ= T2X( JS) >*/
  5237.         *t2xj = t2x[js - 1];
  5238. /*<       T2YJ= T2Y( JS) >*/
  5239.         *t2yj = t2y[js - 1];
  5240. /*<       T2ZJ= T2Z( JS) >*/
  5241.         *t2zj = t2z[js - 1];
  5242. /*<       XJ= X( JS) >*/
  5243.         dataj_1.xj = data_1.x[js - 1];
  5244. /*<       YJ= Y( JS) >*/
  5245.         dataj_1.yj = data_1.y[js - 1];
  5246. /*<       ZJ= Z( JS) >*/
  5247.         dataj_1.zj = data_1.z[js - 1];
  5248. /*     GROUND LOOP */
  5249. /*<       S= BI( JS) >*/
  5250.         dataj_1.s = data_1.bi[js - 1];
  5251. /*<       DO 12  IP=1, KSYMP >*/
  5252.         i__3 = gnd_1.ksymp;
  5253.         for (ip = 1; ip <= i__3; ++ip) {
  5254. /*<       IPGND= IP >*/
  5255.         dataj_1.ipgnd = ip;
  5256. /*<       IF( IPCH.NE. J.AND. ICGO.EQ.1) GOTO 9 >*/
  5257.         if (ipch != j && icgo == 1) {
  5258.             goto L9;
  5259.         }
  5260. /*<       IF( IP.EQ.2) GOTO 9 >*/
  5261.         if (ip == 2) {
  5262.             goto L9;
  5263.         }
  5264. /*<       IF( ICGO.GT.1) GOTO 6 >*/
  5265.         if (icgo > 1) {
  5266.             goto L6;
  5267.         }
  5268. /*<       CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL) >*/
  5269.         pcint_(&xi, &yi, &zi, &cabi, &sabi, &salpi, emel);
  5270. /*<       PY= PI* SI( I)* FSIGN >*/
  5271.         d__1 = pi * data_1.si[i - 1];
  5272.         py = d__1 * fsign;
  5273. /*<       PX= SIN( PY) >*/
  5274.         px = sin(py);
  5275. /*<       PY= COS( PY) >*/
  5276.         py = cos(py);
  5277. /*<       EXC= EMEL(9)* FSIGN >*/
  5278.         z__1.r = fsign * emel[8].r, z__1.i = fsign * emel[8].i;
  5279.         dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  5280. /*<       CALL TRIO( I) >*/
  5281.         trio_(&i);
  5282. /*<       IF( I.GT. N1) GOTO 3 >*/
  5283.         if (i > data_1.n1) {
  5284.             goto L3;
  5285.         }
  5286. /*<       IL= NEQS+ ICONX( I) >*/
  5287.         il = neqs + data_1.iconx[i - 1];
  5288. /*<       GOTO 4 >*/
  5289.         goto L4;
  5290. /*<     3 IL= I- NCW >*/
  5291. L3:
  5292.         il = i - *ncw;
  5293. /*<       IF( I.LE. NP) IL=(( IL-1)/ NP)*2* MP+ IL >*/
  5294.         if (i <= data_1.np) {
  5295.             il = ((il - 1) / data_1.np << 1) * data_1.mp + il;
  5296.         }
  5297. /*<     4 IF( ITRP.NE.0) GOTO 5 >*/
  5298. L4:
  5299.         if (*itrp != 0) {
  5300.             goto L5;
  5301.         }
  5302. /*<    >*/
  5303.         i__4 = k + il * cw_dim1;
  5304.         i__5 = k + il * cw_dim1;
  5305.         d__2 = segj_1.ax[segj_1.jsno - 1] + segj_1.bx[segj_1.jsno - 1]
  5306.              * px;
  5307.         d__1 = d__2 + segj_1.cx[segj_1.jsno - 1] * py;
  5308.         z__2.r = d__1 * dataj_1.exc.r, z__2.i = d__1 * dataj_1.exc.i;
  5309.         z__1.r = cw[i__5].r + z__2.r, z__1.i = cw[i__5].i + z__2.i;
  5310.         cw[i__4].r = z__1.r, cw[i__4].i = z__1.i;
  5311. /*<       GOTO 6 >*/
  5312.         goto L6;
  5313. /*<    >*/
  5314. L5:
  5315.         i__4 = il + k * cw_dim1;
  5316.         i__5 = il + k * cw_dim1;
  5317.         d__2 = segj_1.ax[segj_1.jsno - 1] + segj_1.bx[segj_1.jsno - 1]
  5318.              * px;
  5319.         d__1 = d__2 + segj_1.cx[segj_1.jsno - 1] * py;
  5320.         z__2.r = d__1 * dataj_1.exc.r, z__2.i = d__1 * dataj_1.exc.i;
  5321.         z__1.r = cw[i__5].r + z__2.r, z__1.i = cw[i__5].i + z__2.i;
  5322.         cw[i__4].r = z__1.r, cw[i__4].i = z__1.i;
  5323. /*<     6 IF( ITRP.NE.0) GOTO 7 >*/
  5324. L6:
  5325.         if (*itrp != 0) {
  5326.             goto L7;
  5327.         }
  5328. /*<       CM( K, JL-1)= EMEL( ICGO) >*/
  5329.         i__4 = k + (jl - 1) * cm_dim1;
  5330.         i__5 = icgo - 1;
  5331.         cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
  5332. /*<       CM( K, JL)= EMEL( ICGO+4) >*/
  5333.         i__4 = k + jl * cm_dim1;
  5334.         i__5 = icgo + 3;
  5335.         cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
  5336. /*<       GOTO 8 >*/
  5337.         goto L8;
  5338. /*<     7 CM( JL-1, K)= EMEL( ICGO) >*/
  5339. L7:
  5340.         i__4 = jl - 1 + k * cm_dim1;
  5341.         i__5 = icgo - 1;
  5342.         cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
  5343. /*<       CM( JL, K)= EMEL( ICGO+4) >*/
  5344.         i__4 = jl + k * cm_dim1;
  5345.         i__5 = icgo + 3;
  5346.         cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
  5347. /*<     8 ICGO= ICGO+1 >*/
  5348. L8:
  5349.         ++icgo;
  5350. /*<       IF( ICGO.EQ.5) ICGO=1 >*/
  5351.         if (icgo == 5) {
  5352.             icgo = 1;
  5353.         }
  5354. /*<       GOTO 11 >*/
  5355.         goto L11;
  5356. /*<     9 CALL UNERE( XI, YI, ZI) >*/
  5357. L9:
  5358.         unere_(&xi, &yi, &zi);
  5359. /*     NORMAL FILL */
  5360. /*<       IF( ITRP.NE.0) GOTO 10 >*/
  5361.         if (*itrp != 0) {
  5362.             goto L10;
  5363.         }
  5364. /*<       CM( K, JL-1)= CM( K, JL-1)+ EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
  5365.         i__4 = k + (jl - 1) * cm_dim1;
  5366.         i__5 = k + (jl - 1) * cm_dim1;
  5367.         z__4.r = cabi * dataj_1.exk.r, z__4.i = cabi * dataj_1.exk.i;
  5368.         z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
  5369.         z__5.r = sabi * dataj_1.eyk.r, z__5.i = sabi * dataj_1.eyk.i;
  5370.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5371.         z__6.r = salpi * dataj_1.ezk.r, z__6.i = salpi * 
  5372.             dataj_1.ezk.i;
  5373.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5374.         cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
  5375. /*<       CM( K, JL)= CM( K, JL)+ EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
  5376.         i__4 = k + jl * cm_dim1;
  5377.         i__5 = k + jl * cm_dim1;
  5378.         z__4.r = cabi * dataj_1.exs.r, z__4.i = cabi * dataj_1.exs.i;
  5379.         z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
  5380.         z__5.r = sabi * dataj_1.eys.r, z__5.i = sabi * dataj_1.eys.i;
  5381.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5382.         z__6.r = salpi * dataj_1.ezs.r, z__6.i = salpi * 
  5383.             dataj_1.ezs.i;
  5384.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5385.         cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
  5386. /*     TRANSPOSED FILL */
  5387. /*<       GOTO 11 >*/
  5388.         goto L11;
  5389. /*<    10 CM( JL-1, K)= CM( JL-1, K)+ EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
  5390. L10:
  5391.         i__4 = jl - 1 + k * cm_dim1;
  5392.         i__5 = jl - 1 + k * cm_dim1;
  5393.         z__4.r = cabi * dataj_1.exk.r, z__4.i = cabi * dataj_1.exk.i;
  5394.         z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
  5395.         z__5.r = sabi * dataj_1.eyk.r, z__5.i = sabi * dataj_1.eyk.i;
  5396.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5397.         z__6.r = salpi * dataj_1.ezk.r, z__6.i = salpi * 
  5398.             dataj_1.ezk.i;
  5399.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5400.         cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
  5401. /*<       CM( JL, K)= CM( JL, K)+ EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
  5402.         i__4 = jl + k * cm_dim1;
  5403.         i__5 = jl + k * cm_dim1;
  5404.         z__4.r = cabi * dataj_1.exs.r, z__4.i = cabi * dataj_1.exs.i;
  5405.         z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
  5406.         z__5.r = sabi * dataj_1.eys.r, z__5.i = sabi * dataj_1.eys.i;
  5407.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5408.         z__6.r = salpi * dataj_1.ezs.r, z__6.i = salpi * 
  5409.             dataj_1.ezs.i;
  5410.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5411.         cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
  5412. /*<    11 CONTINUE >*/
  5413. L11:
  5414. /*<    12 CONTINUE >*/
  5415. /* L12: */
  5416.         ;
  5417.         }
  5418.     }
  5419.     }
  5420. /*     FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ON */
  5421. /*     OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY 
  5422. */
  5423. /*<       RETURN >*/
  5424.     return 0;
  5425. /*<    13 IF( J1.LT. I1.OR. J1.GT. I2) GOTO 16 >*/
  5426. L13:
  5427.     if (*j1 < *i1 || *j1 > *i2) {
  5428.     goto L16;
  5429.     }
  5430. /*<       IPCH= ICON1( J1) >*/
  5431.     ipch = data_1.icon1[*j1 - 1];
  5432. /*<       IF( IPCH.LT.10000) GOTO 14 >*/
  5433.     if (ipch < 10000) {
  5434.     goto L14;
  5435.     }
  5436. /*<       IPCH= IPCH-10000 >*/
  5437.     ipch += -10000;
  5438. /*<       FSIGN=-1. >*/
  5439.     fsign = -1.;
  5440. /*<       GOTO 15 >*/
  5441.     goto L15;
  5442. /*<    14 IPCH= ICON2( J1) >*/
  5443. L14:
  5444.     ipch = data_1.icon2[*j1 - 1];
  5445. /*<       IF( IPCH.LT.10000) GOTO 16 >*/
  5446.     if (ipch < 10000) {
  5447.     goto L16;
  5448.     }
  5449. /*<       IPCH= IPCH-10000 >*/
  5450.     ipch += -10000;
  5451. /*<       FSIGN=1. >*/
  5452.     fsign = 1.;
  5453. /*<    15 IF( IPCH.GT. M1) GOTO 16 >*/
  5454. L15:
  5455.     if (ipch > data_1.m1) {
  5456.     goto L16;
  5457.     }
  5458. /*<       JS= LDP- IPCH >*/
  5459.     js = ldp - ipch;
  5460. /*<       IPGND=1 >*/
  5461.     dataj_1.ipgnd = 1;
  5462. /*<       T1XJ= T1X( JS) >*/
  5463.     *t1xj = t1x[js - 1];
  5464. /*<       T1YJ= T1Y( JS) >*/
  5465.     *t1yj = t1y[js - 1];
  5466. /*<       T1ZJ= T1Z( JS) >*/
  5467.     *t1zj = t1z[js - 1];
  5468. /*<       T2XJ= T2X( JS) >*/
  5469.     *t2xj = t2x[js - 1];
  5470. /*<       T2YJ= T2Y( JS) >*/
  5471.     *t2yj = t2y[js - 1];
  5472. /*<       T2ZJ= T2Z( JS) >*/
  5473.     *t2zj = t2z[js - 1];
  5474. /*<       XJ= X( JS) >*/
  5475.     dataj_1.xj = data_1.x[js - 1];
  5476. /*<       YJ= Y( JS) >*/
  5477.     dataj_1.yj = data_1.y[js - 1];
  5478. /*<       ZJ= Z( JS) >*/
  5479.     dataj_1.zj = data_1.z[js - 1];
  5480. /*<       S= BI( JS) >*/
  5481.     dataj_1.s = data_1.bi[js - 1];
  5482. /*<       XI= X( J1) >*/
  5483.     xi = data_1.x[*j1 - 1];
  5484. /*<       YI= Y( J1) >*/
  5485.     yi = data_1.y[*j1 - 1];
  5486. /*<       ZI= Z( J1) >*/
  5487.     zi = data_1.z[*j1 - 1];
  5488. /*<       CABI= CAB( J1) >*/
  5489.     cabi = cab[*j1 - 1];
  5490. /*<       SABI= SAB( J1) >*/
  5491.     sabi = sab[*j1 - 1];
  5492. /*<       SALPI= SALP( J1) >*/
  5493.     salpi = angl_1.salp[*j1 - 1];
  5494. /*<       CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL) >*/
  5495.     pcint_(&xi, &yi, &zi, &cabi, &sabi, &salpi, emel);
  5496. /*<       PY= PI* SI( J1)* FSIGN >*/
  5497.     d__1 = pi * data_1.si[*j1 - 1];
  5498.     py = d__1 * fsign;
  5499. /*<       PX= SIN( PY) >*/
  5500.     px = sin(py);
  5501. /*<       PY= COS( PY) >*/
  5502.     py = cos(py);
  5503. /*<       EXC= EMEL(9)* FSIGN >*/
  5504.     z__1.r = fsign * emel[8].r, z__1.i = fsign * emel[8].i;
  5505.     dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  5506. /*<       IL= JCO( JSNO) >*/
  5507.     il = segj_1.jco[segj_1.jsno - 1];
  5508. /*<       K= J1- I1+1 >*/
  5509.     k = *j1 - *i1 + 1;
  5510. /*<    >*/
  5511.     i__3 = k + il * cw_dim1;
  5512.     i__2 = k + il * cw_dim1;
  5513.     d__2 = segj_1.ax[segj_1.jsno - 1] + segj_1.bx[segj_1.jsno - 1] * px;
  5514.     d__1 = d__2 + segj_1.cx[segj_1.jsno - 1] * py;
  5515.     z__2.r = d__1 * dataj_1.exc.r, z__2.i = d__1 * dataj_1.exc.i;
  5516.     z__1.r = cw[i__2].r + z__2.r, z__1.i = cw[i__2].i + z__2.i;
  5517.     cw[i__3].r = z__1.r, cw[i__3].i = z__1.i;
  5518. /*<    16 RETURN >*/
  5519. L16:
  5520.     return 0;
  5521. /*<       END >*/
  5522. } /* cmsw_ */
  5523.  
  5524. #undef t2zj
  5525. #undef t2yj
  5526. #undef t2xj
  5527. #undef t1zj
  5528. #undef t1yj
  5529. #undef t1xj
  5530. #undef sab
  5531. #undef cab
  5532. #undef t2z
  5533. #undef t2y
  5534. #undef t2x
  5535. #undef t1z
  5536. #undef t1y
  5537. #undef t1x
  5538.  
  5539.  
  5540. /* *** */
  5541. /*     DOUBLE PRECISION 6/4/85 */
  5542.  
  5543. /*<       SUBROUTINE CMWS( J, I1, I2, CM, NR, CW, NW, ITRP) >*/
  5544. /* Subroutine */ int cmws_(j, i1, i2, cm, nr, cw, nw, itrp)
  5545. integer *j, *i1, *i2;
  5546. doublecomplex *cm;
  5547. integer *nr;
  5548. doublecomplex *cw;
  5549. integer *nw, *itrp;
  5550. {
  5551.     /* System generated locals */
  5552.     integer cm_dim1, cm_offset, cw_dim1, cw_offset, i__1, i__2, i__3, i__4, 
  5553.         i__5, i__6, i__7;
  5554.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
  5555.  
  5556.     /* Local variables */
  5557.     static integer i;
  5558.     extern /* Subroutine */ int hsfld_();
  5559.     static integer ij, ik, js;
  5560.     static doublereal xi;
  5561.     static integer ipatch;
  5562.     static doublereal yi, zi;
  5563.     static integer jx;
  5564.     static doublereal tx, ty, tz;
  5565. #define t1x ((doublereal *)&data_1 + 1800)
  5566. #define t1y ((doublereal *)&data_1 + 3000)
  5567. #define t1z ((doublereal *)&data_1 + 3600)
  5568. #define t2x ((doublereal *)&data_1 + 4201)
  5569. #define t2y ((doublereal *)&data_1 + 4601)
  5570. #define t2z ((doublereal *)&data_1 + 5001)
  5571. #define cab ((doublereal *)&data_1 + 3000)
  5572. #define sab ((doublereal *)&data_1 + 3600)
  5573.     static doublecomplex etc;
  5574.     static integer ldp;
  5575.     static doublecomplex etk;
  5576.     static integer ipr;
  5577.     static doublecomplex ets;
  5578.  
  5579. /* *** */
  5580.  
  5581. /*     CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS */
  5582.  
  5583. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  5584. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  5585. /*<    >*/
  5586. /*<    >*/
  5587. /*<       COMMON  /ANGL/ SALP( NM) >*/
  5588. /*<    >*/
  5589. /*<    >*/
  5590. /*<       DIMENSION  CM( NR,1), CW( NW,1), CAB(1), SAB(1) >*/
  5591. /*<       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
  5592. /*<       EQUIVALENCE(CAB,ALP),(SAB,BET),(T1X,SI),(T1Y,ALP),(T1Z,BET) >*/
  5593. /*<       EQUIVALENCE(T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG) >*/
  5594. /*<       LDP= LD+1 >*/
  5595.     /* Parameter adjustments */
  5596.     cw_dim1 = *nw;
  5597.     cw_offset = cw_dim1 + 1;
  5598.     cw -= cw_offset;
  5599.     cm_dim1 = *nr;
  5600.     cm_offset = cm_dim1 + 1;
  5601.     cm -= cm_offset;
  5602.  
  5603.     /* Function Body */
  5604.     ldp = data_1.ld + 1;
  5605. /*<       S= SI( J) >*/
  5606.     dataj_1.s = data_1.si[*j - 1];
  5607. /*<       B= BI( J) >*/
  5608.     dataj_1.b = data_1.bi[*j - 1];
  5609. /*<       XJ= X( J) >*/
  5610.     dataj_1.xj = data_1.x[*j - 1];
  5611. /*<       YJ= Y( J) >*/
  5612.     dataj_1.yj = data_1.y[*j - 1];
  5613. /*<       ZJ= Z( J) >*/
  5614.     dataj_1.zj = data_1.z[*j - 1];
  5615. /*<       CABJ= CAB( J) >*/
  5616.     dataj_1.cabj = cab[*j - 1];
  5617. /*<       SABJ= SAB( J) >*/
  5618.     dataj_1.sabj = sab[*j - 1];
  5619.  
  5620. /*     OBSERVATION LOOP */
  5621.  
  5622. /*<       SALPJ= SALP( J) >*/
  5623.     dataj_1.salpj = angl_1.salp[*j - 1];
  5624. /*<       IPR=0 >*/
  5625.     ipr = 0;
  5626. /*<       DO 9  I= I1, I2 >*/
  5627.     i__1 = *i2;
  5628.     for (i = *i1; i <= i__1; ++i) {
  5629. /*<       IPR= IPR+1 >*/
  5630.     ++ipr;
  5631. /*<       IPATCH=( I+1)/2 >*/
  5632.     ipatch = (i + 1) / 2;
  5633. /*<       IK= I-( I/2)*2 >*/
  5634.     ik = i - (i / 2 << 1);
  5635. /*<       IF( IK.EQ.0.AND. IPR.NE.1) GOTO 1 >*/
  5636.     if (ik == 0 && ipr != 1) {
  5637.         goto L1;
  5638.     }
  5639. /*<       JS= LDP- IPATCH >*/
  5640.     js = ldp - ipatch;
  5641. /*<       XI= X( JS) >*/
  5642.     xi = data_1.x[js - 1];
  5643. /*<       YI= Y( JS) >*/
  5644.     yi = data_1.y[js - 1];
  5645. /*<       ZI= Z( JS) >*/
  5646.     zi = data_1.z[js - 1];
  5647. /*<       CALL HSFLD( XI, YI, ZI,0.) >*/
  5648.     hsfld_(&xi, &yi, &zi, &c_b594);
  5649. /*<       IF( IK.EQ.0) GOTO 1 >*/
  5650.     if (ik == 0) {
  5651.         goto L1;
  5652.     }
  5653. /*<       TX= T2X( JS) >*/
  5654.     tx = t2x[js - 1];
  5655. /*<       TY= T2Y( JS) >*/
  5656.     ty = t2y[js - 1];
  5657. /*<       TZ= T2Z( JS) >*/
  5658.     tz = t2z[js - 1];
  5659. /*<       GOTO 2 >*/
  5660.     goto L2;
  5661. /*<     1 TX= T1X( JS) >*/
  5662. L1:
  5663.     tx = t1x[js - 1];
  5664. /*<       TY= T1Y( JS) >*/
  5665.     ty = t1y[js - 1];
  5666. /*<       TZ= T1Z( JS) >*/
  5667.     tz = t1z[js - 1];
  5668. /*<     2 ETK=-( EXK* TX+ EYK* TY+ EZK* TZ)* SALP( JS) >*/
  5669. L2:
  5670.     z__5.r = tx * dataj_1.exk.r, z__5.i = tx * dataj_1.exk.i;
  5671.     z__6.r = ty * dataj_1.eyk.r, z__6.i = ty * dataj_1.eyk.i;
  5672.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  5673.     z__7.r = tz * dataj_1.ezk.r, z__7.i = tz * dataj_1.ezk.i;
  5674.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  5675.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  5676.     i__2 = js - 1;
  5677.     z__1.r = angl_1.salp[i__2] * z__2.r, z__1.i = angl_1.salp[i__2] * 
  5678.         z__2.i;
  5679.     etk.r = z__1.r, etk.i = z__1.i;
  5680. /*<       ETS=-( EXS* TX+ EYS* TY+ EZS* TZ)* SALP( JS) >*/
  5681.     z__5.r = tx * dataj_1.exs.r, z__5.i = tx * dataj_1.exs.i;
  5682.     z__6.r = ty * dataj_1.eys.r, z__6.i = ty * dataj_1.eys.i;
  5683.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  5684.     z__7.r = tz * dataj_1.ezs.r, z__7.i = tz * dataj_1.ezs.i;
  5685.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  5686.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  5687.     i__2 = js - 1;
  5688.     z__1.r = angl_1.salp[i__2] * z__2.r, z__1.i = angl_1.salp[i__2] * 
  5689.         z__2.i;
  5690.     ets.r = z__1.r, ets.i = z__1.i;
  5691.  
  5692. /*     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTI
  5693. ON */
  5694. /*     DATA. */
  5695.  
  5696. /*<       ETC=-( EXC* TX+ EYC* TY+ EZC* TZ)* SALP( JS) >*/
  5697.     z__5.r = tx * dataj_1.exc.r, z__5.i = tx * dataj_1.exc.i;
  5698.     z__6.r = ty * dataj_1.eyc.r, z__6.i = ty * dataj_1.eyc.i;
  5699.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  5700.     z__7.r = tz * dataj_1.ezc.r, z__7.i = tz * dataj_1.ezc.i;
  5701.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  5702.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  5703.     i__2 = js - 1;
  5704.     z__1.r = angl_1.salp[i__2] * z__2.r, z__1.i = angl_1.salp[i__2] * 
  5705.         z__2.i;
  5706.     etc.r = z__1.r, etc.i = z__1.i;
  5707. /*     NORMAL FILL */
  5708. /*<       IF( ITRP.NE.0) GOTO 4 >*/
  5709.     if (*itrp != 0) {
  5710.         goto L4;
  5711.     }
  5712. /*<       DO 3  IJ=1, JSNO >*/
  5713.     i__2 = segj_1.jsno;
  5714.     for (ij = 1; ij <= i__2; ++ij) {
  5715. /*<       JX= JCO( IJ) >*/
  5716.         jx = segj_1.jco[ij - 1];
  5717. /*<    >*/
  5718. /* L3: */
  5719.         i__3 = ipr + jx * cm_dim1;
  5720.         i__4 = ipr + jx * cm_dim1;
  5721.         i__5 = ij - 1;
  5722.         z__4.r = segj_1.ax[i__5] * etk.r, z__4.i = segj_1.ax[i__5] * 
  5723.             etk.i;
  5724.         z__3.r = cm[i__4].r + z__4.r, z__3.i = cm[i__4].i + z__4.i;
  5725.         i__6 = ij - 1;
  5726.         z__5.r = segj_1.bx[i__6] * ets.r, z__5.i = segj_1.bx[i__6] * 
  5727.             ets.i;
  5728.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5729.         i__7 = ij - 1;
  5730.         z__6.r = segj_1.cx[i__7] * etc.r, z__6.i = segj_1.cx[i__7] * 
  5731.             etc.i;
  5732.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5733.         cm[i__3].r = z__1.r, cm[i__3].i = z__1.i;
  5734.     }
  5735. /*<       GOTO 9 >*/
  5736.     goto L9;
  5737. /*     TRANSPOSED FILL */
  5738. /*<     4 IF( ITRP.EQ.2) GOTO 6 >*/
  5739. L4:
  5740.     if (*itrp == 2) {
  5741.         goto L6;
  5742.     }
  5743. /*<       DO 5  IJ=1, JSNO >*/
  5744.     i__3 = segj_1.jsno;
  5745.     for (ij = 1; ij <= i__3; ++ij) {
  5746. /*<       JX= JCO( IJ) >*/
  5747.         jx = segj_1.jco[ij - 1];
  5748. /*<    >*/
  5749. /* L5: */
  5750.         i__4 = jx + ipr * cm_dim1;
  5751.         i__5 = jx + ipr * cm_dim1;
  5752.         i__6 = ij - 1;
  5753.         z__4.r = segj_1.ax[i__6] * etk.r, z__4.i = segj_1.ax[i__6] * 
  5754.             etk.i;
  5755.         z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
  5756.         i__7 = ij - 1;
  5757.         z__5.r = segj_1.bx[i__7] * ets.r, z__5.i = segj_1.bx[i__7] * 
  5758.             ets.i;
  5759.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5760.         i__2 = ij - 1;
  5761.         z__6.r = segj_1.cx[i__2] * etc.r, z__6.i = segj_1.cx[i__2] * 
  5762.             etc.i;
  5763.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5764.         cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
  5765.     }
  5766. /*     TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW) */
  5767. /*<       GOTO 9 >*/
  5768.     goto L9;
  5769. /*<     6 DO 8  IJ=1, JSNO >*/
  5770. L6:
  5771.     i__4 = segj_1.jsno;
  5772.     for (ij = 1; ij <= i__4; ++ij) {
  5773. /*<       JX= JCO( IJ) >*/
  5774.         jx = segj_1.jco[ij - 1];
  5775. /*<       IF( JX.GT. NR) GOTO 7 >*/
  5776.         if (jx > *nr) {
  5777.         goto L7;
  5778.         }
  5779. /*<    >*/
  5780.         i__5 = jx + ipr * cm_dim1;
  5781.         i__6 = jx + ipr * cm_dim1;
  5782.         i__7 = ij - 1;
  5783.         z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] * 
  5784.             etk.i;
  5785.         z__3.r = cm[i__6].r + z__4.r, z__3.i = cm[i__6].i + z__4.i;
  5786.         i__2 = ij - 1;
  5787.         z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] * 
  5788.             ets.i;
  5789.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5790.         i__3 = ij - 1;
  5791.         z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] * 
  5792.             etc.i;
  5793.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5794.         cm[i__5].r = z__1.r, cm[i__5].i = z__1.i;
  5795. /*<       GOTO 8 >*/
  5796.         goto L8;
  5797. /*<     7 JX= JX- NR >*/
  5798. L7:
  5799.         jx -= *nr;
  5800. /*<    >*/
  5801.         i__5 = jx + ipr * cw_dim1;
  5802.         i__6 = jx + ipr * cw_dim1;
  5803.         i__7 = ij - 1;
  5804.         z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] * 
  5805.             etk.i;
  5806.         z__3.r = cw[i__6].r + z__4.r, z__3.i = cw[i__6].i + z__4.i;
  5807.         i__2 = ij - 1;
  5808.         z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] * 
  5809.             ets.i;
  5810.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  5811.         i__3 = ij - 1;
  5812.         z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] * 
  5813.             etc.i;
  5814.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  5815.         cw[i__5].r = z__1.r, cw[i__5].i = z__1.i;
  5816. /*<     8 CONTINUE >*/
  5817. L8:
  5818.         ;
  5819.     }
  5820. /*<     9 CONTINUE >*/
  5821. L9:
  5822.     ;
  5823.     }
  5824. /*<       RETURN >*/
  5825.     return 0;
  5826. /*<       END >*/
  5827. } /* cmws_ */
  5828.  
  5829. #undef sab
  5830. #undef cab
  5831. #undef t2z
  5832. #undef t2y
  5833. #undef t2x
  5834. #undef t1z
  5835. #undef t1y
  5836. #undef t1x
  5837.  
  5838.  
  5839. /* *** */
  5840. /*     DOUBLE PRECISION 6/4/85 */
  5841.  
  5842. /*<       SUBROUTINE CMWW( J, I1, I2, CM, NR, CW, NW, ITRP) >*/
  5843. /* Subroutine */ int cmww_(j, i1, i2, cm, nr, cw, nw, itrp)
  5844. integer *j, *i1, *i2;
  5845. doublecomplex *cm;
  5846. integer *nr;
  5847. doublecomplex *cw;
  5848. integer *nw, *itrp;
  5849. {
  5850.     /* System generated locals */
  5851.     integer cm_dim1, cm_offset, cw_dim1, cw_offset, i__1, i__2, i__3, i__4, 
  5852.         i__5, i__6, i__7;
  5853.     doublereal d__1, d__2;
  5854.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
  5855.  
  5856.     /* Local variables */
  5857.     extern /* Subroutine */ int efld_();
  5858.     static doublereal sabi;
  5859.     static integer i;
  5860.     static doublereal salpi, ai;
  5861.     static integer ij;
  5862.     static doublereal xi, yi, zi;
  5863.     static integer jx;
  5864. #define cab ((doublereal *)&data_1 + 3000)
  5865. #define sab ((doublereal *)&data_1 + 3600)
  5866.     static doublecomplex etc, etk;
  5867.     static integer ipr;
  5868.     static doublecomplex ets;
  5869.     static doublereal cabi;
  5870.  
  5871. /* *** */
  5872. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  5873.  
  5874. /*     CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS */
  5875.  
  5876. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  5877. /*<    >*/
  5878. /*<    >*/
  5879. /*<       COMMON  /ANGL/ SALP( NM) >*/
  5880. /*<    >*/
  5881. /*<    >*/
  5882. /*<       DIMENSION  CM( NR,1), CW( NW,1), CAB(1), SAB(1) >*/
  5883. /*     SET SOURCE SEGMENT PARAMETERS */
  5884. /*<       EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
  5885. /*<       S= SI( J) >*/
  5886.     /* Parameter adjustments */
  5887.     cw_dim1 = *nw;
  5888.     cw_offset = cw_dim1 + 1;
  5889.     cw -= cw_offset;
  5890.     cm_dim1 = *nr;
  5891.     cm_offset = cm_dim1 + 1;
  5892.     cm -= cm_offset;
  5893.  
  5894.     /* Function Body */
  5895.     dataj_1.s = data_1.si[*j - 1];
  5896. /*<       B= BI( J) >*/
  5897.     dataj_1.b = data_1.bi[*j - 1];
  5898. /*<       XJ= X( J) >*/
  5899.     dataj_1.xj = data_1.x[*j - 1];
  5900. /*<       YJ= Y( J) >*/
  5901.     dataj_1.yj = data_1.y[*j - 1];
  5902. /*<       ZJ= Z( J) >*/
  5903.     dataj_1.zj = data_1.z[*j - 1];
  5904. /*<       CABJ= CAB( J) >*/
  5905.     dataj_1.cabj = cab[*j - 1];
  5906. /*<       SABJ= SAB( J) >*/
  5907.     dataj_1.sabj = sab[*j - 1];
  5908. /*<       SALPJ= SALP( J) >*/
  5909.     dataj_1.salpj = angl_1.salp[*j - 1];
  5910. /*     DECIDE WETHER EXT. T.W. APPROX. CAN BE USED */
  5911. /*<       IF( IEXK.EQ.0) GOTO 16 >*/
  5912.     if (dataj_1.iexk == 0) {
  5913.     goto L16;
  5914.     }
  5915. /*<       IPR= ICON1( J) >*/
  5916.     ipr = data_1.icon1[*j - 1];
  5917. /*<       IF( IPR) 1,6,2 >*/
  5918.     if (ipr < 0) {
  5919.     goto L1;
  5920.     } else if (ipr == 0) {
  5921.     goto L6;
  5922.     } else {
  5923.     goto L2;
  5924.     }
  5925. /*<     1 IPR=- IPR >*/
  5926. L1:
  5927.     ipr = -ipr;
  5928. /*<       IF(- ICON1( IPR).NE. J) GOTO 7 >*/
  5929.     if (-data_1.icon1[ipr - 1] != *j) {
  5930.     goto L7;
  5931.     }
  5932. /*<       GOTO 4 >*/
  5933.     goto L4;
  5934. /*<     2 IF( IPR.NE. J) GOTO 3 >*/
  5935. L2:
  5936.     if (ipr != *j) {
  5937.     goto L3;
  5938.     }
  5939. /*<       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7 >*/
  5940.     if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) {
  5941.     goto L7;
  5942.     }
  5943. /*<       GOTO 5 >*/
  5944.     goto L5;
  5945. /*<     3 IF( ICON2( IPR).NE. J) GOTO 7 >*/
  5946. L3:
  5947.     if (data_1.icon2[ipr - 1] != *j) {
  5948.     goto L7;
  5949.     }
  5950. /*<     4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
  5951. L4:
  5952.     d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
  5953.     xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
  5954. /*<       IF( XI.LT.0.999999D+0) GOTO 7 >*/
  5955.     if (xi < .999999) {
  5956.     goto L7;
  5957.     }
  5958. /*<       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7 >*/
  5959.     if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
  5960.     goto L7;
  5961.     }
  5962. /*<     5 IND1=0 >*/
  5963. L5:
  5964.     dataj_1.ind1 = 0;
  5965. /*<       GOTO 8 >*/
  5966.     goto L8;
  5967. /*<     6 IND1=1 >*/
  5968. L6:
  5969.     dataj_1.ind1 = 1;
  5970. /*<       GOTO 8 >*/
  5971.     goto L8;
  5972. /*<     7 IND1=2 >*/
  5973. L7:
  5974.     dataj_1.ind1 = 2;
  5975. /*<     8 IPR= ICON2( J) >*/
  5976. L8:
  5977.     ipr = data_1.icon2[*j - 1];
  5978. /*<       IF( IPR) 9,14,10 >*/
  5979.     if (ipr < 0) {
  5980.     goto L9;
  5981.     } else if (ipr == 0) {
  5982.     goto L14;
  5983.     } else {
  5984.     goto L10;
  5985.     }
  5986. /*<     9 IPR=- IPR >*/
  5987. L9:
  5988.     ipr = -ipr;
  5989. /*<       IF(- ICON2( IPR).NE. J) GOTO 15 >*/
  5990.     if (-data_1.icon2[ipr - 1] != *j) {
  5991.     goto L15;
  5992.     }
  5993. /*<       GOTO 12 >*/
  5994.     goto L12;
  5995. /*<    10 IF( IPR.NE. J) GOTO 11 >*/
  5996. L10:
  5997.     if (ipr != *j) {
  5998.     goto L11;
  5999.     }
  6000. /*<       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15 >*/
  6001.     if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) {
  6002.     goto L15;
  6003.     }
  6004. /*<       GOTO 13 >*/
  6005.     goto L13;
  6006. /*<    11 IF( ICON1( IPR).NE. J) GOTO 15 >*/
  6007. L11:
  6008.     if (data_1.icon1[ipr - 1] != *j) {
  6009.     goto L15;
  6010.     }
  6011. /*<    12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
  6012. L12:
  6013.     d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
  6014.     xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
  6015. /*<       IF( XI.LT.0.999999D+0) GOTO 15 >*/
  6016.     if (xi < .999999) {
  6017.     goto L15;
  6018.     }
  6019. /*<       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15 >*/
  6020.     if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
  6021.     goto L15;
  6022.     }
  6023. /*<    13 IND2=0 >*/
  6024. L13:
  6025.     dataj_1.ind2 = 0;
  6026. /*<       GOTO 16 >*/
  6027.     goto L16;
  6028. /*<    14 IND2=1 >*/
  6029. L14:
  6030.     dataj_1.ind2 = 1;
  6031. /*<       GOTO 16 >*/
  6032.     goto L16;
  6033. /*<    15 IND2=2 >*/
  6034. L15:
  6035.     dataj_1.ind2 = 2;
  6036.  
  6037. /*     OBSERVATION LOOP */
  6038.  
  6039. /*<    16 CONTINUE >*/
  6040. L16:
  6041. /*<       IPR=0 >*/
  6042.     ipr = 0;
  6043. /*<       DO 23  I= I1, I2 >*/
  6044.     i__1 = *i2;
  6045.     for (i = *i1; i <= i__1; ++i) {
  6046. /*<       IPR= IPR+1 >*/
  6047.     ++ipr;
  6048. /*<       IJ= I- J >*/
  6049.     ij = i - *j;
  6050. /*<       XI= X( I) >*/
  6051.     xi = data_1.x[i - 1];
  6052. /*<       YI= Y( I) >*/
  6053.     yi = data_1.y[i - 1];
  6054. /*<       ZI= Z( I) >*/
  6055.     zi = data_1.z[i - 1];
  6056. /*<       AI= BI( I) >*/
  6057.     ai = data_1.bi[i - 1];
  6058. /*<       CABI= CAB( I) >*/
  6059.     cabi = cab[i - 1];
  6060. /*<       SABI= SAB( I) >*/
  6061.     sabi = sab[i - 1];
  6062. /*<       SALPI= SALP( I) >*/
  6063.     salpi = angl_1.salp[i - 1];
  6064. /*<       CALL EFLD( XI, YI, ZI, AI, IJ) >*/
  6065.     efld_(&xi, &yi, &zi, &ai, &ij);
  6066. /*<       ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
  6067.     z__3.r = cabi * dataj_1.exk.r, z__3.i = cabi * dataj_1.exk.i;
  6068.     z__4.r = sabi * dataj_1.eyk.r, z__4.i = sabi * dataj_1.eyk.i;
  6069.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  6070.     z__5.r = salpi * dataj_1.ezk.r, z__5.i = salpi * dataj_1.ezk.i;
  6071.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  6072.     etk.r = z__1.r, etk.i = z__1.i;
  6073. /*<       ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
  6074.     z__3.r = cabi * dataj_1.exs.r, z__3.i = cabi * dataj_1.exs.i;
  6075.     z__4.r = sabi * dataj_1.eys.r, z__4.i = sabi * dataj_1.eys.i;
  6076.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  6077.     z__5.r = salpi * dataj_1.ezs.r, z__5.i = salpi * dataj_1.ezs.i;
  6078.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  6079.     ets.r = z__1.r, ets.i = z__1.i;
  6080.  
  6081. /*     FILL MATRIX ELEMENTS.  ELEMENT LOCATIONS DETERMINED BY CONNECTI
  6082. ON */
  6083. /*     DATA. */
  6084.  
  6085. /*<       ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI >*/
  6086.     z__3.r = cabi * dataj_1.exc.r, z__3.i = cabi * dataj_1.exc.i;
  6087.     z__4.r = sabi * dataj_1.eyc.r, z__4.i = sabi * dataj_1.eyc.i;
  6088.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  6089.     z__5.r = salpi * dataj_1.ezc.r, z__5.i = salpi * dataj_1.ezc.i;
  6090.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  6091.     etc.r = z__1.r, etc.i = z__1.i;
  6092. /*     NORMAL FILL */
  6093. /*<       IF( ITRP.NE.0) GOTO 18 >*/
  6094.     if (*itrp != 0) {
  6095.         goto L18;
  6096.     }
  6097. /*<       DO 17  IJ=1, JSNO >*/
  6098.     i__2 = segj_1.jsno;
  6099.     for (ij = 1; ij <= i__2; ++ij) {
  6100. /*<       JX= JCO( IJ) >*/
  6101.         jx = segj_1.jco[ij - 1];
  6102. /*<    >*/
  6103. /* L17: */
  6104.         i__3 = ipr + jx * cm_dim1;
  6105.         i__4 = ipr + jx * cm_dim1;
  6106.         i__5 = ij - 1;
  6107.         z__4.r = segj_1.ax[i__5] * etk.r, z__4.i = segj_1.ax[i__5] * 
  6108.             etk.i;
  6109.         z__3.r = cm[i__4].r + z__4.r, z__3.i = cm[i__4].i + z__4.i;
  6110.         i__6 = ij - 1;
  6111.         z__5.r = segj_1.bx[i__6] * ets.r, z__5.i = segj_1.bx[i__6] * 
  6112.             ets.i;
  6113.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  6114.         i__7 = ij - 1;
  6115.         z__6.r = segj_1.cx[i__7] * etc.r, z__6.i = segj_1.cx[i__7] * 
  6116.             etc.i;
  6117.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  6118.         cm[i__3].r = z__1.r, cm[i__3].i = z__1.i;
  6119.     }
  6120. /*<       GOTO 23 >*/
  6121.     goto L23;
  6122. /*     TRANSPOSED FILL */
  6123. /*<    18 IF( ITRP.EQ.2) GOTO 20 >*/
  6124. L18:
  6125.     if (*itrp == 2) {
  6126.         goto L20;
  6127.     }
  6128. /*<       DO 19  IJ=1, JSNO >*/
  6129.     i__3 = segj_1.jsno;
  6130.     for (ij = 1; ij <= i__3; ++ij) {
  6131. /*<       JX= JCO( IJ) >*/
  6132.         jx = segj_1.jco[ij - 1];
  6133. /*<    >*/
  6134. /* L19: */
  6135.         i__4 = jx + ipr * cm_dim1;
  6136.         i__5 = jx + ipr * cm_dim1;
  6137.         i__6 = ij - 1;
  6138.         z__4.r = segj_1.ax[i__6] * etk.r, z__4.i = segj_1.ax[i__6] * 
  6139.             etk.i;
  6140.         z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
  6141.         i__7 = ij - 1;
  6142.         z__5.r = segj_1.bx[i__7] * ets.r, z__5.i = segj_1.bx[i__7] * 
  6143.             ets.i;
  6144.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  6145.         i__2 = ij - 1;
  6146.         z__6.r = segj_1.cx[i__2] * etc.r, z__6.i = segj_1.cx[i__2] * 
  6147.             etc.i;
  6148.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  6149.         cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
  6150.     }
  6151. /*     TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME.  (=CW
  6152. ) */
  6153. /*<       GOTO 23 >*/
  6154.     goto L23;
  6155. /*<    20 DO 22  IJ=1, JSNO >*/
  6156. L20:
  6157.     i__4 = segj_1.jsno;
  6158.     for (ij = 1; ij <= i__4; ++ij) {
  6159. /*<       JX= JCO( IJ) >*/
  6160.         jx = segj_1.jco[ij - 1];
  6161. /*<       IF( JX.GT. NR) GOTO 21 >*/
  6162.         if (jx > *nr) {
  6163.         goto L21;
  6164.         }
  6165. /*<    >*/
  6166.         i__5 = jx + ipr * cm_dim1;
  6167.         i__6 = jx + ipr * cm_dim1;
  6168.         i__7 = ij - 1;
  6169.         z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] * 
  6170.             etk.i;
  6171.         z__3.r = cm[i__6].r + z__4.r, z__3.i = cm[i__6].i + z__4.i;
  6172.         i__2 = ij - 1;
  6173.         z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] * 
  6174.             ets.i;
  6175.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  6176.         i__3 = ij - 1;
  6177.         z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] * 
  6178.             etc.i;
  6179.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  6180.         cm[i__5].r = z__1.r, cm[i__5].i = z__1.i;
  6181. /*<       GOTO 22 >*/
  6182.         goto L22;
  6183. /*<    21 JX= JX- NR >*/
  6184. L21:
  6185.         jx -= *nr;
  6186. /*<    >*/
  6187.         i__5 = jx + ipr * cw_dim1;
  6188.         i__6 = jx + ipr * cw_dim1;
  6189.         i__7 = ij - 1;
  6190.         z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] * 
  6191.             etk.i;
  6192.         z__3.r = cw[i__6].r + z__4.r, z__3.i = cw[i__6].i + z__4.i;
  6193.         i__2 = ij - 1;
  6194.         z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] * 
  6195.             ets.i;
  6196.         z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  6197.         i__3 = ij - 1;
  6198.         z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] * 
  6199.             etc.i;
  6200.         z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  6201.         cw[i__5].r = z__1.r, cw[i__5].i = z__1.i;
  6202. /*<    22 CONTINUE >*/
  6203. L22:
  6204.         ;
  6205.     }
  6206. /*<    23 CONTINUE >*/
  6207. L23:
  6208.     ;
  6209.     }
  6210. /*<       RETURN >*/
  6211.     return 0;
  6212. /*<       END >*/
  6213. } /* cmww_ */
  6214.  
  6215. #undef sab
  6216. #undef cab
  6217.  
  6218.  
  6219. /* *** */
  6220. /*     DOUBLE PRECISION 6/4/85 */
  6221.  
  6222. /*<       SUBROUTINE CONECT( IGND) >*/
  6223. /* Subroutine */ int conect_(ignd)
  6224. integer *ignd;
  6225. {
  6226.     /* Initialized data */
  6227.  
  6228.     static integer jmax = 30;
  6229.     static doublereal smin = .001;
  6230.     static integer nsmax = 50;
  6231.     static integer npmax = 10;
  6232.  
  6233.     /* Format strings */
  6234.     static char fmt_54[] = "(/,3x,\002GROUND PLANE SPECIFIED.\002)";
  6235.     static char fmt_55[] = "(/,3x,\002WHERE WIRE ENDS TOUCH GROUND, CURRENT \
  6236. WILL BE \002,\002INTERPOLATED TO IMAGE IN GROUND PLANE.\002,/)";
  6237.     static char fmt_56[] = "(\002 GEOMETRY DATA ERROR-- SEGMENT\002,i5,\002 \
  6238. EXTENDS BELOW GRO\002,\002UND\002)";
  6239.     static char fmt_57[] = "(\002 GEOMETRY DATA ERROR--SEGMENT\002,i5,\002 L\
  6240. IES IN GROUND \002,\002PLANE.\002)";
  6241.     static char fmt_62[] = "(\002 ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.\
  6242. F. SEGMENTS\002,\002OR PATCHES EXCEEDS LIMIT OF\002,i5)";
  6243.     static char fmt_58[] = "(/,3x,\002TOTAL SEGMENTS USED=\002,i5,5x,\002NO.\
  6244.  SEG. IN \002,\002A SY\002,\002MMETRIC CELL=\002,i5,5x,\002SYMMETRY FLAG=\
  6245. \002,i3)";
  6246.     static char fmt_61[] = "(3x,\002TOTAL PATCHES USED=\002,i5,6x,\002NO. PA\
  6247. TCHES IN A SYMMET\002,\002RIC CELL=\002,i5)";
  6248.     static char fmt_59[] = "(\002 STRUCTURE HAS\002,i4,\002 FOLD ROTATIONAL \
  6249. SYMMETRY\002,/)";
  6250.     static char fmt_60[] = "(\002 STRUCTURE HAS\002,i2,\002 PLANES OF SYMMET\
  6251. RY\002,/)";
  6252.     static char fmt_50[] = "(//,9x,\002- MULTIPLE WIRE JUNCTIONS -\002,/,1x\
  6253. ,\002JUNCTION\002,4x,\002SEGMENTS  (- FOR END 1, + FOR END 2)\002)";
  6254.     static char fmt_51[] = "(1x,i5,5x,20i5,/,(11x,20i5))";
  6255.     static char fmt_52[] = "(2x,\002NONE\002)";
  6256.     static char fmt_53[] = "(\002 CONNECT - SEGMENT CONNECTION ERROR FOR SEG\
  6257. MENT\002,i5)";
  6258.  
  6259.     /* System generated locals */
  6260.     integer i__1, i__2, i__3;
  6261.     doublereal d__1, d__2, d__3, d__4;
  6262.  
  6263.     /* Builtin functions */
  6264.     integer s_wsfe(), e_wsfe();
  6265.     /* Subroutine */ int s_stop();
  6266.     double sqrt();
  6267.     integer do_fio();
  6268.  
  6269.     /* Local variables */
  6270.     static integer iend, jend, iseg;
  6271.     static doublereal slen;
  6272.     static integer i, j, nsflg;
  6273.     extern /* Subroutine */ int subph_();
  6274. #define x2 ((doublereal *)&data_1 + 1800)
  6275. #define y2 ((doublereal *)&data_1 + 3000)
  6276. #define z2 ((doublereal *)&data_1 + 3600)
  6277.     static integer ic;
  6278.     static doublereal xa;
  6279.     static integer ix;
  6280.     static doublereal ya, za, xs, ys, zs, xi1, yi1, zi1, xi2, yi2, zi2, sep;
  6281.  
  6282.     /* Fortran I/O blocks */
  6283.     static cilist io___409 = { 0, 6, 0, fmt_54, 0 };
  6284.     static cilist io___410 = { 0, 6, 0, fmt_55, 0 };
  6285.     static cilist io___419 = { 0, 6, 0, fmt_56, 0 };
  6286.     static cilist io___423 = { 0, 6, 0, fmt_56, 0 };
  6287.     static cilist io___424 = { 0, 6, 0, fmt_57, 0 };
  6288.     static cilist io___433 = { 0, 6, 0, fmt_62, 0 };
  6289.     static cilist io___434 = { 0, 6, 0, fmt_58, 0 };
  6290.     static cilist io___435 = { 0, 6, 0, fmt_61, 0 };
  6291.     static cilist io___436 = { 0, 6, 0, fmt_59, 0 };
  6292.     static cilist io___437 = { 0, 6, 0, fmt_60, 0 };
  6293.     static cilist io___438 = { 0, 6, 0, fmt_50, 0 };
  6294.     static cilist io___442 = { 0, 6, 0, fmt_62, 0 };
  6295.     static cilist io___443 = { 0, 6, 0, fmt_51, 0 };
  6296.     static cilist io___444 = { 0, 6, 0, fmt_52, 0 };
  6297.     static cilist io___445 = { 0, 6, 0, fmt_53, 0 };
  6298.  
  6299.  
  6300. /* *** */
  6301. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  6302.  
  6303. /*     CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2 
  6304. */
  6305. /*     BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT. */
  6306.  
  6307. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  6308. /*<    >*/
  6309. /*<    >*/
  6310. /*<       DIMENSION  X2(1), Y2(1), Z2(1) >*/
  6311. /*<       EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET) >*/
  6312. /*<       DATA   JMAX/30/, SMIN/1.D-3/, NSMAX/50/, NPMAX/10/ >*/
  6313. /*<       NSCON=0 >*/
  6314.     segj_1.nscon = 0;
  6315. /*<       NPCON=0 >*/
  6316.     segj_1.npcon = 0;
  6317. /*<       IF( IGND.EQ.0) GOTO 3 >*/
  6318.     if (*ignd == 0) {
  6319.     goto L3;
  6320.     }
  6321. /*<       WRITE( 6,54)  >*/
  6322.     s_wsfe(&io___409);
  6323.     e_wsfe();
  6324. /*<       IF( IGND.GT.0) WRITE( 6,55)  >*/
  6325.     if (*ignd > 0) {
  6326.     s_wsfe(&io___410);
  6327.     e_wsfe();
  6328.     }
  6329. /*<       IF( IPSYM.NE.2) GOTO 1 >*/
  6330.     if (data_1.ipsym != 2) {
  6331.     goto L1;
  6332.     }
  6333. /*<       NP=2* NP >*/
  6334.     data_1.np <<= 1;
  6335. /*<       MP=2* MP >*/
  6336.     data_1.mp <<= 1;
  6337. /*<     1 IF( IABS( IPSYM).LE.2) GOTO 2 >*/
  6338. L1:
  6339.     if (abs(data_1.ipsym) <= 2) {
  6340.     goto L2;
  6341.     }
  6342. /*<       NP= N >*/
  6343.     data_1.np = data_1.n;
  6344. /*<       MP= M >*/
  6345.     data_1.mp = data_1.m;
  6346. /*<     2 IF( NP.GT. N) STOP >*/
  6347. L2:
  6348.     if (data_1.np > data_1.n) {
  6349.     s_stop("", 0L);
  6350.     }
  6351. /*<       IF( NP.EQ. N.AND. MP.EQ. M) IPSYM=0 >*/
  6352.     if (data_1.np == data_1.n && data_1.mp == data_1.m) {
  6353.     data_1.ipsym = 0;
  6354.     }
  6355. /*<     3 IF( N.EQ.0) GOTO 26 >*/
  6356. L3:
  6357.     if (data_1.n == 0) {
  6358.     goto L26;
  6359.     }
  6360. /*<       DO 15  I=1, N >*/
  6361.     i__1 = data_1.n;
  6362.     for (i = 1; i <= i__1; ++i) {
  6363. /*<       ICONX( I)=0 >*/
  6364.     data_1.iconx[i - 1] = 0;
  6365. /*<       XI1= X( I) >*/
  6366.     xi1 = data_1.x[i - 1];
  6367. /*<       YI1= Y( I) >*/
  6368.     yi1 = data_1.y[i - 1];
  6369. /*<       ZI1= Z( I) >*/
  6370.     zi1 = data_1.z[i - 1];
  6371. /*<       XI2= X2( I) >*/
  6372.     xi2 = x2[i - 1];
  6373. /*<       YI2= Y2( I) >*/
  6374.     yi2 = y2[i - 1];
  6375. /*<       ZI2= Z2( I) >*/
  6376.     zi2 = z2[i - 1];
  6377.  
  6378. /*     DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT. */
  6379.  
  6380. /*<       SLEN= SQRT(( XI2- XI1)**2+( YI2- YI1)**2+( ZI2- ZI1)**2)* SMIN >*/
  6381. /* Computing 2nd power */
  6382.     d__2 = xi2 - xi1;
  6383. /* Computing 2nd power */
  6384.     d__3 = yi2 - yi1;
  6385.     d__1 = d__2 * d__2 + d__3 * d__3;
  6386. /* Computing 2nd power */
  6387.     d__4 = zi2 - zi1;
  6388.     slen = sqrt(d__1 + d__4 * d__4) * smin;
  6389. /*<       IF( IGND.LT.1) GOTO 5 >*/
  6390.     if (*ignd < 1) {
  6391.         goto L5;
  6392.     }
  6393. /*<       IF( ZI1.GT.- SLEN) GOTO 4 >*/
  6394.     if (zi1 > -slen) {
  6395.         goto L4;
  6396.     }
  6397. /*<       WRITE( 6,56)  I >*/
  6398.     s_wsfe(&io___419);
  6399.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  6400.     e_wsfe();
  6401. /*<       STOP >*/
  6402.     s_stop("", 0L);
  6403. /*<     4 IF( ZI1.GT. SLEN) GOTO 5 >*/
  6404. L4:
  6405.     if (zi1 > slen) {
  6406.         goto L5;
  6407.     }
  6408. /*<       ICON1( I)= I >*/
  6409.     data_1.icon1[i - 1] = i;
  6410. /*<       Z( I)=0. >*/
  6411.     data_1.z[i - 1] = 0.;
  6412. /*<       GOTO 9 >*/
  6413.     goto L9;
  6414. /*<     5 IC= I >*/
  6415. L5:
  6416.     ic = i;
  6417. /*<       DO 7  J=2, N >*/
  6418.     i__2 = data_1.n;
  6419.     for (j = 2; j <= i__2; ++j) {
  6420. /*<       IC= IC+1 >*/
  6421.         ++ic;
  6422. /*<       IF( IC.GT. N) IC=1 >*/
  6423.         if (ic > data_1.n) {
  6424.         ic = 1;
  6425.         }
  6426. /*<       SEP= ABS( XI1- X( IC))+ ABS( YI1- Y( IC))+ ABS( ZI1- Z( IC)) >*/
  6427.         d__4 = (d__1 = xi1 - data_1.x[ic - 1], abs(d__1)) + (d__2 = yi1 - 
  6428.             data_1.y[ic - 1], abs(d__2));
  6429.         sep = d__4 + (d__3 = zi1 - data_1.z[ic - 1], abs(d__3));
  6430. /*<       IF( SEP.GT. SLEN) GOTO 6 >*/
  6431.         if (sep > slen) {
  6432.         goto L6;
  6433.         }
  6434. /*<       ICON1( I)=- IC >*/
  6435.         data_1.icon1[i - 1] = -ic;
  6436. /*<       GOTO 8 >*/
  6437.         goto L8;
  6438. /*<     6 SEP= ABS( XI1- X2( IC))+ ABS( YI1- Y2( IC))+ ABS( ZI1- Z2( IC)) >*/
  6439. L6:
  6440.         d__4 = (d__1 = xi1 - x2[ic - 1], abs(d__1)) + (d__2 = yi1 - y2[ic 
  6441.             - 1], abs(d__2));
  6442.         sep = d__4 + (d__3 = zi1 - z2[ic - 1], abs(d__3));
  6443. /*<       IF( SEP.GT. SLEN) GOTO 7 >*/
  6444.         if (sep > slen) {
  6445.         goto L7;
  6446.         }
  6447. /*<       ICON1( I)= IC >*/
  6448.         data_1.icon1[i - 1] = ic;
  6449. /*<       GOTO 8 >*/
  6450.         goto L8;
  6451. /*<     7 CONTINUE >*/
  6452. L7:
  6453.         ;
  6454.     }
  6455. /*<       IF( I.LT. N2.AND. ICON1( I).GT.10000) GOTO 8 >*/
  6456.     if (i < data_1.n2 && data_1.icon1[i - 1] > 10000) {
  6457.         goto L8;
  6458.     }
  6459.  
  6460. /*     DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT. */
  6461.  
  6462. /*<       ICON1( I)=0 >*/
  6463.     data_1.icon1[i - 1] = 0;
  6464. /*<     8 IF( IGND.LT.1) GOTO 12 >*/
  6465. L8:
  6466.     if (*ignd < 1) {
  6467.         goto L12;
  6468.     }
  6469. /*<     9 IF( ZI2.GT.- SLEN) GOTO 10 >*/
  6470. L9:
  6471.     if (zi2 > -slen) {
  6472.         goto L10;
  6473.     }
  6474. /*<       WRITE( 6,56)  I >*/
  6475.     s_wsfe(&io___423);
  6476.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  6477.     e_wsfe();
  6478. /*<       STOP >*/
  6479.     s_stop("", 0L);
  6480. /*<    10 IF( ZI2.GT. SLEN) GOTO 12 >*/
  6481. L10:
  6482.     if (zi2 > slen) {
  6483.         goto L12;
  6484.     }
  6485. /*<       IF( ICON1( I).NE. I) GOTO 11 >*/
  6486.     if (data_1.icon1[i - 1] != i) {
  6487.         goto L11;
  6488.     }
  6489. /*<       WRITE( 6,57)  I >*/
  6490.     s_wsfe(&io___424);
  6491.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  6492.     e_wsfe();
  6493. /*<       STOP >*/
  6494.     s_stop("", 0L);
  6495. /*<    11 ICON2( I)= I >*/
  6496. L11:
  6497.     data_1.icon2[i - 1] = i;
  6498. /*<       Z2( I)=0. >*/
  6499.     z2[i - 1] = 0.;
  6500. /*<       GOTO 15 >*/
  6501.     goto L15;
  6502. /*<    12 IC= I >*/
  6503. L12:
  6504.     ic = i;
  6505. /*<       DO 14  J=2, N >*/
  6506.     i__2 = data_1.n;
  6507.     for (j = 2; j <= i__2; ++j) {
  6508. /*<       IC= IC+1 >*/
  6509.         ++ic;
  6510. /*<       IF( IC.GT. N) IC=1 >*/
  6511.         if (ic > data_1.n) {
  6512.         ic = 1;
  6513.         }
  6514. /*<       SEP= ABS( XI2- X( IC))+ ABS( YI2- Y( IC))+ ABS( ZI2- Z( IC)) >*/
  6515.         d__4 = (d__1 = xi2 - data_1.x[ic - 1], abs(d__1)) + (d__2 = yi2 - 
  6516.             data_1.y[ic - 1], abs(d__2));
  6517.         sep = d__4 + (d__3 = zi2 - data_1.z[ic - 1], abs(d__3));
  6518. /*<       IF( SEP.GT. SLEN) GOTO 13 >*/
  6519.         if (sep > slen) {
  6520.         goto L13;
  6521.         }
  6522. /*<       ICON2( I)= IC >*/
  6523.         data_1.icon2[i - 1] = ic;
  6524. /*<       GOTO 15 >*/
  6525.         goto L15;
  6526. /*<    13 SEP= ABS( XI2- X2( IC))+ ABS( YI2- Y2( IC))+ ABS( ZI2- Z2( IC)) >*/
  6527. L13:
  6528.         d__4 = (d__1 = xi2 - x2[ic - 1], abs(d__1)) + (d__2 = yi2 - y2[ic 
  6529.             - 1], abs(d__2));
  6530.         sep = d__4 + (d__3 = zi2 - z2[ic - 1], abs(d__3));
  6531. /*<       IF( SEP.GT. SLEN) GOTO 14 >*/
  6532.         if (sep > slen) {
  6533.         goto L14;
  6534.         }
  6535. /*<       ICON2( I)=- IC >*/
  6536.         data_1.icon2[i - 1] = -ic;
  6537. /*<       GOTO 15 >*/
  6538.         goto L15;
  6539. /*<    14 CONTINUE >*/
  6540. L14:
  6541.         ;
  6542.     }
  6543. /*<       IF( I.LT. N2.AND. ICON2( I).GT.10000) GOTO 15 >*/
  6544.     if (i < data_1.n2 && data_1.icon2[i - 1] > 10000) {
  6545.         goto L15;
  6546.     }
  6547. /*<       ICON2( I)=0 >*/
  6548.     data_1.icon2[i - 1] = 0;
  6549. /*<    15 CONTINUE >*/
  6550. L15:
  6551.     ;
  6552.     }
  6553. /*     FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES */
  6554. /*<       IF( M.EQ.0) GOTO 26 >*/
  6555.     if (data_1.m == 0) {
  6556.     goto L26;
  6557.     }
  6558. /*<       IX= LD+1- M1 >*/
  6559.     ix = data_1.ld + 1 - data_1.m1;
  6560. /*<       I= M2 >*/
  6561.     i = data_1.m2;
  6562. /*<    16 IF( I.GT. M) GOTO 20 >*/
  6563. L16:
  6564.     if (i > data_1.m) {
  6565.     goto L20;
  6566.     }
  6567. /*<       IX= IX-1 >*/
  6568.     --ix;
  6569. /*<       XS= X( IX) >*/
  6570.     xs = data_1.x[ix - 1];
  6571. /*<       YS= Y( IX) >*/
  6572.     ys = data_1.y[ix - 1];
  6573. /*<       ZS= Z( IX) >*/
  6574.     zs = data_1.z[ix - 1];
  6575. /*<       DO 18  ISEG=1, N >*/
  6576.     i__1 = data_1.n;
  6577.     for (iseg = 1; iseg <= i__1; ++iseg) {
  6578. /*<       XI1= X( ISEG) >*/
  6579.     xi1 = data_1.x[iseg - 1];
  6580. /*<       YI1= Y( ISEG) >*/
  6581.     yi1 = data_1.y[iseg - 1];
  6582. /*<       ZI1= Z( ISEG) >*/
  6583.     zi1 = data_1.z[iseg - 1];
  6584. /*<       XI2= X2( ISEG) >*/
  6585.     xi2 = x2[iseg - 1];
  6586. /*<       YI2= Y2( ISEG) >*/
  6587.     yi2 = y2[iseg - 1];
  6588. /*<       ZI2= Z2( ISEG) >*/
  6589.     zi2 = z2[iseg - 1];
  6590. /*     FOR FIRST END OF SEGMENT */
  6591. /*<       SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN >*/
  6592.     d__4 = (d__1 = xi2 - xi1, abs(d__1)) + (d__2 = yi2 - yi1, abs(d__2));
  6593.     slen = (d__4 + (d__3 = zi2 - zi1, abs(d__3))) * smin;
  6594. /*<       SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS) >*/
  6595.     d__4 = (d__1 = xi1 - xs, abs(d__1)) + (d__2 = yi1 - ys, abs(d__2));
  6596.     sep = d__4 + (d__3 = zi1 - zs, abs(d__3));
  6597. /*     CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC. 
  6598. */
  6599. /*<       IF( SEP.GT. SLEN) GOTO 17 >*/
  6600.     if (sep > slen) {
  6601.         goto L17;
  6602.     }
  6603. /*<       ICON1( ISEG)=10000+ I >*/
  6604.     data_1.icon1[iseg - 1] = i + 10000;
  6605. /*<       IC=0 >*/
  6606.     ic = 0;
  6607. /*<    >*/
  6608.     subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
  6609.         xs, &ys, &zs);
  6610. /*<       GOTO 19 >*/
  6611.     goto L19;
  6612. /*<    17 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS) >*/
  6613. L17:
  6614.     d__4 = (d__1 = xi2 - xs, abs(d__1)) + (d__2 = yi2 - ys, abs(d__2));
  6615.     sep = d__4 + (d__3 = zi2 - zs, abs(d__3));
  6616. /*<       IF( SEP.GT. SLEN) GOTO 18 >*/
  6617.     if (sep > slen) {
  6618.         goto L18;
  6619.     }
  6620. /*<       ICON2( ISEG)=10000+ I >*/
  6621.     data_1.icon2[iseg - 1] = i + 10000;
  6622. /*<       IC=0 >*/
  6623.     ic = 0;
  6624. /*<    >*/
  6625.     subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
  6626.         xs, &ys, &zs);
  6627. /*<       GOTO 19 >*/
  6628.     goto L19;
  6629. /*<    18 CONTINUE >*/
  6630. L18:
  6631.     ;
  6632.     }
  6633. /*<    19 I= I+1 >*/
  6634. L19:
  6635.     ++i;
  6636. /*     REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES. */
  6637. /*<       GOTO 16 >*/
  6638.     goto L16;
  6639. /*<    20 IF( M1.EQ.0.OR. N2.GT. N) GOTO 26 >*/
  6640. L20:
  6641.     if (data_1.m1 == 0 || data_1.n2 > data_1.n) {
  6642.     goto L26;
  6643.     }
  6644. /*<       IX= LD+1 >*/
  6645.     ix = data_1.ld + 1;
  6646. /*<       I=1 >*/
  6647.     i = 1;
  6648. /*<    21 IF( I.GT. M1) GOTO 25 >*/
  6649. L21:
  6650.     if (i > data_1.m1) {
  6651.     goto L25;
  6652.     }
  6653. /*<       IX= IX-1 >*/
  6654.     --ix;
  6655. /*<       XS= X( IX) >*/
  6656.     xs = data_1.x[ix - 1];
  6657. /*<       YS= Y( IX) >*/
  6658.     ys = data_1.y[ix - 1];
  6659. /*<       ZS= Z( IX) >*/
  6660.     zs = data_1.z[ix - 1];
  6661. /*<       DO 23  ISEG= N2, N >*/
  6662.     i__1 = data_1.n;
  6663.     for (iseg = data_1.n2; iseg <= i__1; ++iseg) {
  6664. /*<       XI1= X( ISEG) >*/
  6665.     xi1 = data_1.x[iseg - 1];
  6666. /*<       YI1= Y( ISEG) >*/
  6667.     yi1 = data_1.y[iseg - 1];
  6668. /*<       ZI1= Z( ISEG) >*/
  6669.     zi1 = data_1.z[iseg - 1];
  6670. /*<       XI2= X2( ISEG) >*/
  6671.     xi2 = x2[iseg - 1];
  6672. /*<       YI2= Y2( ISEG) >*/
  6673.     yi2 = y2[iseg - 1];
  6674. /*<       ZI2= Z2( ISEG) >*/
  6675.     zi2 = z2[iseg - 1];
  6676. /*<       SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN >*/
  6677.     d__4 = (d__1 = xi2 - xi1, abs(d__1)) + (d__2 = yi2 - yi1, abs(d__2));
  6678.     slen = (d__4 + (d__3 = zi2 - zi1, abs(d__3))) * smin;
  6679. /*<       SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS) >*/
  6680.     d__4 = (d__1 = xi1 - xs, abs(d__1)) + (d__2 = yi1 - ys, abs(d__2));
  6681.     sep = d__4 + (d__3 = zi1 - zs, abs(d__3));
  6682. /*<       IF( SEP.GT. SLEN) GOTO 22 >*/
  6683.     if (sep > slen) {
  6684.         goto L22;
  6685.     }
  6686. /*<       ICON1( ISEG)=10001+ M >*/
  6687.     data_1.icon1[iseg - 1] = data_1.m + 10001;
  6688. /*<       IC=1 >*/
  6689.     ic = 1;
  6690. /*<       NPCON= NPCON+1 >*/
  6691.     ++segj_1.npcon;
  6692. /*<       IPCON( NPCON)= I >*/
  6693.     segj_1.ipcon[segj_1.npcon - 1] = i;
  6694. /*<    >*/
  6695.     subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
  6696.         xs, &ys, &zs);
  6697. /*<       GOTO 24 >*/
  6698.     goto L24;
  6699. /*<    22 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS) >*/
  6700. L22:
  6701.     d__4 = (d__1 = xi2 - xs, abs(d__1)) + (d__2 = yi2 - ys, abs(d__2));
  6702.     sep = d__4 + (d__3 = zi2 - zs, abs(d__3));
  6703. /*<       IF( SEP.GT. SLEN) GOTO 23 >*/
  6704.     if (sep > slen) {
  6705.         goto L23;
  6706.     }
  6707. /*<       ICON2( ISEG)=10001+ M >*/
  6708.     data_1.icon2[iseg - 1] = data_1.m + 10001;
  6709. /*<       IC=1 >*/
  6710.     ic = 1;
  6711. /*<       NPCON= NPCON+1 >*/
  6712.     ++segj_1.npcon;
  6713. /*<       IPCON( NPCON)= I >*/
  6714.     segj_1.ipcon[segj_1.npcon - 1] = i;
  6715. /*<    >*/
  6716.     subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
  6717.         xs, &ys, &zs);
  6718. /*<       GOTO 24 >*/
  6719.     goto L24;
  6720. /*<    23 CONTINUE >*/
  6721. L23:
  6722.     ;
  6723.     }
  6724. /*<    24 I= I+1 >*/
  6725. L24:
  6726.     ++i;
  6727. /*<       GOTO 21 >*/
  6728.     goto L21;
  6729. /*<    25 IF( NPCON.LE. NPMAX) GOTO 26 >*/
  6730. L25:
  6731.     if (segj_1.npcon <= npmax) {
  6732.     goto L26;
  6733.     }
  6734. /*<       WRITE( 6,62)  NPMAX >*/
  6735.     s_wsfe(&io___433);
  6736.     do_fio(&c__1, (char *)&npmax, (ftnlen)sizeof(integer));
  6737.     e_wsfe();
  6738. /*<       STOP >*/
  6739.     s_stop("", 0L);
  6740. /*<    26 WRITE( 6,58)  N, NP, IPSYM >*/
  6741. L26:
  6742.     s_wsfe(&io___434);
  6743.     do_fio(&c__1, (char *)&data_1.n, (ftnlen)sizeof(integer));
  6744.     do_fio(&c__1, (char *)&data_1.np, (ftnlen)sizeof(integer));
  6745.     do_fio(&c__1, (char *)&data_1.ipsym, (ftnlen)sizeof(integer));
  6746.     e_wsfe();
  6747. /*<       IF( M.GT.0) WRITE( 6,61)  M, MP >*/
  6748.     if (data_1.m > 0) {
  6749.     s_wsfe(&io___435);
  6750.     do_fio(&c__1, (char *)&data_1.m, (ftnlen)sizeof(integer));
  6751.     do_fio(&c__1, (char *)&data_1.mp, (ftnlen)sizeof(integer));
  6752.     e_wsfe();
  6753.     }
  6754. /*<       ISEG=( N+ M)/( NP+ MP) >*/
  6755.     iseg = (data_1.n + data_1.m) / (data_1.np + data_1.mp);
  6756. /*<       IF( ISEG.EQ.1) GOTO 30 >*/
  6757.     if (iseg == 1) {
  6758.     goto L30;
  6759.     }
  6760. /*<       IF( IPSYM) 28,27,29 >*/
  6761.     if (data_1.ipsym < 0) {
  6762.     goto L28;
  6763.     } else if (data_1.ipsym == 0) {
  6764.     goto L27;
  6765.     } else {
  6766.     goto L29;
  6767.     }
  6768. /*<    27 STOP >*/
  6769. L27:
  6770.     s_stop("", 0L);
  6771. /*<    28 WRITE( 6,59)  ISEG >*/
  6772. L28:
  6773.     s_wsfe(&io___436);
  6774.     do_fio(&c__1, (char *)&iseg, (ftnlen)sizeof(integer));
  6775.     e_wsfe();
  6776. /*<       GOTO 30 >*/
  6777.     goto L30;
  6778. /*<    29 IC= ISEG/2 >*/
  6779. L29:
  6780.     ic = iseg / 2;
  6781. /*<       IF( ISEG.EQ.8) IC=3 >*/
  6782.     if (iseg == 8) {
  6783.     ic = 3;
  6784.     }
  6785. /*<       WRITE( 6,60)  IC >*/
  6786.     s_wsfe(&io___437);
  6787.     do_fio(&c__1, (char *)&ic, (ftnlen)sizeof(integer));
  6788.     e_wsfe();
  6789. /*<    30 IF( N.EQ.0) GOTO 48 >*/
  6790. L30:
  6791.     if (data_1.n == 0) {
  6792.     goto L48;
  6793.     }
  6794. /*<       WRITE( 6,50)  >*/
  6795.     s_wsfe(&io___438);
  6796.     e_wsfe();
  6797. /*     ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE.  PRINT JUNCTIONS */
  6798.  
  6799. /*     OF 3 OR MORE SEG.  ALSO FIND OLD SEG. CONNECTING TO NEW SEG. */
  6800. /*<       ISEG=0 >*/
  6801.     iseg = 0;
  6802. /*<       DO 44  J=1, N >*/
  6803.     i__1 = data_1.n;
  6804.     for (j = 1; j <= i__1; ++j) {
  6805. /*<       IEND=-1 >*/
  6806.     iend = -1;
  6807. /*<       JEND=-1 >*/
  6808.     jend = -1;
  6809. /*<       IX= ICON1( J) >*/
  6810.     ix = data_1.icon1[j - 1];
  6811. /*<       IC=1 >*/
  6812.     ic = 1;
  6813. /*<       JCO(1)=- J >*/
  6814.     segj_1.jco[0] = -j;
  6815. /*<       XA= X( J) >*/
  6816.     xa = data_1.x[j - 1];
  6817. /*<       YA= Y( J) >*/
  6818.     ya = data_1.y[j - 1];
  6819. /*<       ZA= Z( J) >*/
  6820.     za = data_1.z[j - 1];
  6821. /*<    31 IF( IX.EQ.0) GOTO 43 >*/
  6822. L31:
  6823.     if (ix == 0) {
  6824.         goto L43;
  6825.     }
  6826. /*<       IF( IX.EQ. J) GOTO 43 >*/
  6827.     if (ix == j) {
  6828.         goto L43;
  6829.     }
  6830. /*<       IF( IX.GT.10000) GOTO 43 >*/
  6831.     if (ix > 10000) {
  6832.         goto L43;
  6833.     }
  6834. /*<       NSFLG=0 >*/
  6835.     nsflg = 0;
  6836. /*<    32 IF( IX) 33,49,34 >*/
  6837. L32:
  6838.     if (ix < 0) {
  6839.         goto L33;
  6840.     } else if (ix == 0) {
  6841.         goto L49;
  6842.     } else {
  6843.         goto L34;
  6844.     }
  6845. /*<    33 IX=- IX >*/
  6846. L33:
  6847.     ix = -ix;
  6848. /*<       GOTO 35 >*/
  6849.     goto L35;
  6850. /*<    34 JEND=- JEND >*/
  6851. L34:
  6852.     jend = -jend;
  6853. /*<    35 IF( IX.EQ. J) GOTO 37 >*/
  6854. L35:
  6855.     if (ix == j) {
  6856.         goto L37;
  6857.     }
  6858. /*<       IF( IX.LT. J) GOTO 43 >*/
  6859.     if (ix < j) {
  6860.         goto L43;
  6861.     }
  6862. /*<       IC= IC+1 >*/
  6863.     ++ic;
  6864. /*<       IF( IC.GT. JMAX) GOTO 49 >*/
  6865.     if (ic > jmax) {
  6866.         goto L49;
  6867.     }
  6868. /*<       JCO( IC)= IX* JEND >*/
  6869.     segj_1.jco[ic - 1] = ix * jend;
  6870. /*<       IF( IX.GT. N1) NSFLG=1 >*/
  6871.     if (ix > data_1.n1) {
  6872.         nsflg = 1;
  6873.     }
  6874. /*<       IF( JEND.EQ.1) GOTO 36 >*/
  6875.     if (jend == 1) {
  6876.         goto L36;
  6877.     }
  6878. /*<       XA= XA+ X( IX) >*/
  6879.     xa += data_1.x[ix - 1];
  6880. /*<       YA= YA+ Y( IX) >*/
  6881.     ya += data_1.y[ix - 1];
  6882. /*<       ZA= ZA+ Z( IX) >*/
  6883.     za += data_1.z[ix - 1];
  6884. /*<       IX= ICON1( IX) >*/
  6885.     ix = data_1.icon1[ix - 1];
  6886. /*<       GOTO 32 >*/
  6887.     goto L32;
  6888. /*<    36 XA= XA+ X2( IX) >*/
  6889. L36:
  6890.     xa += x2[ix - 1];
  6891. /*<       YA= YA+ Y2( IX) >*/
  6892.     ya += y2[ix - 1];
  6893. /*<       ZA= ZA+ Z2( IX) >*/
  6894.     za += z2[ix - 1];
  6895. /*<       IX= ICON2( IX) >*/
  6896.     ix = data_1.icon2[ix - 1];
  6897. /*<       GOTO 32 >*/
  6898.     goto L32;
  6899. /*<    37 SEP= IC >*/
  6900. L37:
  6901.     sep = (doublereal) ic;
  6902. /*<       XA= XA/ SEP >*/
  6903.     xa /= sep;
  6904. /*<       YA= YA/ SEP >*/
  6905.     ya /= sep;
  6906. /*<       ZA= ZA/ SEP >*/
  6907.     za /= sep;
  6908. /*<       DO 39  I=1, IC >*/
  6909.     i__2 = ic;
  6910.     for (i = 1; i <= i__2; ++i) {
  6911. /*<       IX= JCO( I) >*/
  6912.         ix = segj_1.jco[i - 1];
  6913. /*<       IF( IX.GT.0) GOTO 38 >*/
  6914.         if (ix > 0) {
  6915.         goto L38;
  6916.         }
  6917. /*<       IX=- IX >*/
  6918.         ix = -ix;
  6919. /*<       X( IX)= XA >*/
  6920.         data_1.x[ix - 1] = xa;
  6921. /*<       Y( IX)= YA >*/
  6922.         data_1.y[ix - 1] = ya;
  6923. /*<       Z( IX)= ZA >*/
  6924.         data_1.z[ix - 1] = za;
  6925. /*<       GOTO 39 >*/
  6926.         goto L39;
  6927. /*<    38 X2( IX)= XA >*/
  6928. L38:
  6929.         x2[ix - 1] = xa;
  6930. /*<       Y2( IX)= YA >*/
  6931.         y2[ix - 1] = ya;
  6932. /*<       Z2( IX)= ZA >*/
  6933.         z2[ix - 1] = za;
  6934. /*<    39 CONTINUE >*/
  6935. L39:
  6936.         ;
  6937.     }
  6938. /*<       IF( N1.EQ.0) GOTO 42 >*/
  6939.     if (data_1.n1 == 0) {
  6940.         goto L42;
  6941.     }
  6942. /*<       IF( NSFLG.EQ.0) GOTO 42 >*/
  6943.     if (nsflg == 0) {
  6944.         goto L42;
  6945.     }
  6946. /*<       DO 41  I=1, IC >*/
  6947.     i__2 = ic;
  6948.     for (i = 1; i <= i__2; ++i) {
  6949. /*<       IX= IABS( JCO( I)) >*/
  6950.         ix = (i__3 = segj_1.jco[i - 1], abs(i__3));
  6951. /*<       IF( IX.GT. N1) GOTO 41 >*/
  6952.         if (ix > data_1.n1) {
  6953.         goto L41;
  6954.         }
  6955. /*<       IF( ICONX( IX).NE.0) GOTO 41 >*/
  6956.         if (data_1.iconx[ix - 1] != 0) {
  6957.         goto L41;
  6958.         }
  6959. /*<       NSCON= NSCON+1 >*/
  6960.         ++segj_1.nscon;
  6961. /*<       IF( NSCON.LE. NSMAX) GOTO 40 >*/
  6962.         if (segj_1.nscon <= nsmax) {
  6963.         goto L40;
  6964.         }
  6965. /*<       WRITE( 6,62)  NSMAX >*/
  6966.         s_wsfe(&io___442);
  6967.         do_fio(&c__1, (char *)&nsmax, (ftnlen)sizeof(integer));
  6968.         e_wsfe();
  6969. /*<       STOP >*/
  6970.         s_stop("", 0L);
  6971. /*<    40 ISCON( NSCON)= IX >*/
  6972. L40:
  6973.         segj_1.iscon[segj_1.nscon - 1] = ix;
  6974. /*<       ICONX( IX)= NSCON >*/
  6975.         data_1.iconx[ix - 1] = segj_1.nscon;
  6976. /*<    41 CONTINUE >*/
  6977. L41:
  6978.         ;
  6979.     }
  6980. /*<    42 IF( IC.LT.3) GOTO 43 >*/
  6981. L42:
  6982.     if (ic < 3) {
  6983.         goto L43;
  6984.     }
  6985. /*<       ISEG= ISEG+1 >*/
  6986.     ++iseg;
  6987. /*<       WRITE( 6,51)  ISEG,( JCO( I), I=1, IC) >*/
  6988.     s_wsfe(&io___443);
  6989.     do_fio(&c__1, (char *)&iseg, (ftnlen)sizeof(integer));
  6990.     i__2 = ic;
  6991.     for (i = 1; i <= i__2; ++i) {
  6992.         do_fio(&c__1, (char *)&segj_1.jco[i - 1], (ftnlen)sizeof(integer))
  6993.             ;
  6994.     }
  6995.     e_wsfe();
  6996. /*<    43 IF( IEND.EQ.1) GOTO 44 >*/
  6997. L43:
  6998.     if (iend == 1) {
  6999.         goto L44;
  7000.     }
  7001. /*<       IEND=1 >*/
  7002.     iend = 1;
  7003. /*<       JEND=1 >*/
  7004.     jend = 1;
  7005. /*<       IX= ICON2( J) >*/
  7006.     ix = data_1.icon2[j - 1];
  7007. /*<       IC=1 >*/
  7008.     ic = 1;
  7009. /*<       JCO(1)= J >*/
  7010.     segj_1.jco[0] = j;
  7011. /*<       XA= X2( J) >*/
  7012.     xa = x2[j - 1];
  7013. /*<       YA= Y2( J) >*/
  7014.     ya = y2[j - 1];
  7015. /*<       ZA= Z2( J) >*/
  7016.     za = z2[j - 1];
  7017. /*<       GOTO 31 >*/
  7018.     goto L31;
  7019. /*<    44 CONTINUE >*/
  7020. L44:
  7021.     ;
  7022.     }
  7023. /*<       IF( ISEG.EQ.0) WRITE( 6,52)  >*/
  7024.     if (iseg == 0) {
  7025.     s_wsfe(&io___444);
  7026.     e_wsfe();
  7027.     }
  7028. /*     FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES */
  7029. /*<       IF( N1.EQ.0.OR. M1.EQ. M) GOTO 48 >*/
  7030.     if (data_1.n1 == 0 || data_1.m1 == data_1.m) {
  7031.     goto L48;
  7032.     }
  7033. /*<       DO 47  J=1, N1 >*/
  7034.     i__1 = data_1.n1;
  7035.     for (j = 1; j <= i__1; ++j) {
  7036. /*<       IX= ICON1( J) >*/
  7037.     ix = data_1.icon1[j - 1];
  7038. /*<       IF( IX.LT.10000) GOTO 45 >*/
  7039.     if (ix < 10000) {
  7040.         goto L45;
  7041.     }
  7042. /*<       IX= IX-10000 >*/
  7043.     ix += -10000;
  7044. /*<       IF( IX.GT. M1) GOTO 46 >*/
  7045.     if (ix > data_1.m1) {
  7046.         goto L46;
  7047.     }
  7048. /*<    45 IX= ICON2( J) >*/
  7049. L45:
  7050.     ix = data_1.icon2[j - 1];
  7051. /*<       IF( IX.LT.10000) GOTO 47 >*/
  7052.     if (ix < 10000) {
  7053.         goto L47;
  7054.     }
  7055. /*<       IX= IX-10000 >*/
  7056.     ix += -10000;
  7057. /*<       IF( IX.LT. M2) GOTO 47 >*/
  7058.     if (ix < data_1.m2) {
  7059.         goto L47;
  7060.     }
  7061. /*<    46 IF( ICONX( J).NE.0) GOTO 47 >*/
  7062. L46:
  7063.     if (data_1.iconx[j - 1] != 0) {
  7064.         goto L47;
  7065.     }
  7066. /*<       NSCON= NSCON+1 >*/
  7067.     ++segj_1.nscon;
  7068. /*<       ISCON( NSCON)= J >*/
  7069.     segj_1.iscon[segj_1.nscon - 1] = j;
  7070. /*<       ICONX( J)= NSCON >*/
  7071.     data_1.iconx[j - 1] = segj_1.nscon;
  7072. /*<    47 CONTINUE >*/
  7073. L47:
  7074.     ;
  7075.     }
  7076. /*<    48 CONTINUE >*/
  7077. L48:
  7078. /*<       RETURN >*/
  7079.     return 0;
  7080. /*<    49 WRITE( 6,53)  IX >*/
  7081. L49:
  7082.     s_wsfe(&io___445);
  7083.     do_fio(&c__1, (char *)&ix, (ftnlen)sizeof(integer));
  7084.     e_wsfe();
  7085.  
  7086. /*<       STOP >*/
  7087.     s_stop("", 0L);
  7088. /*<    >*/
  7089. /*<    51 FORMAT(1X,I5,5X,20I5,/,(11X,20I5)) >*/
  7090. /*<    52 FORMAT(2X,'NONE') >*/
  7091. /*<    53 FORMAT(' CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT',I5) >*/
  7092. /*<    54 FORMAT(/,3X,'GROUND PLANE SPECIFIED.') >*/
  7093. /*<    >*/
  7094. /*<    >*/
  7095. /*<    >*/
  7096. /*<    >*/
  7097. /*<    59 FORMAT(' STRUCTURE HAS',I4,' FOLD ROTATIONAL SYMMETRY',/) >*/
  7098. /*<    60 FORMAT(' STRUCTURE HAS',I2,' PLANES OF SYMMETRY',/) >*/
  7099. /*<    >*/
  7100. /*<    >*/
  7101. /*<       END >*/
  7102. } /* conect_ */
  7103.  
  7104. #undef z2
  7105. #undef y2
  7106. #undef x2
  7107.  
  7108.  
  7109. /* *** */
  7110. /*     DOUBLE PRECISION 6/4/85 */
  7111.  
  7112. /*<       SUBROUTINE COUPLE( CUR, WLAM) >*/
  7113. /* Subroutine */ int couple_(cur, wlam)
  7114. doublecomplex *cur;
  7115. doublereal *wlam;
  7116. {
  7117.     /* Format strings */
  7118.     static char fmt_6[] = "(///,36x,\002- - - ISOLATION DATA - - -\002,//,\
  7119. 6x,\002- - COUPLIN\002,\002G BETWEEN - -\002,8x,\002MAXIMUM\002,15x,\002- - \
  7120. - FOR MAXIMUM COUPLING - \002,\002- -\002,/,12x,\002SEG.\002,14x,\002SEG.\
  7121. \002,3x,\002COUPLING\002,4x,\002LOAD IMPEDANCE \002,\002(2ND SEG.)\002,7x\
  7122. ,\002INPUT IMPEDANCE\002,/,2x,\002TAG/SEG.\002,3x,\002NO.\002,4x,\002TAG/'SE\
  7123. G.\002,3x,\002NO.\002,6x,\002(DB)\002,8x,\002REAL\002,9x,\002IMAG.\002,9x\
  7124. ,\002REAL\002,9x,\002IMAG.\002)";
  7125.     static char fmt_7[] = "(2(1x,i4,1x,i4,1x,i5,2x),f9.3,2x,1p,2(2x,e12.5,1x\
  7126. ,e12.5))";
  7127.     static char fmt_8[] = "(2(1x,i4,1x,i4,1x,i5,2x),\002**ERROR** COUPLING I\
  7128. S NOT BETWE\002,\002EN 0 AND 1. (=\002,1p,e12.5,\002)\002)";
  7129.  
  7130.     /* System generated locals */
  7131.     integer i__1, i__2, i__3, i__4;
  7132.     doublereal d__1, d__2;
  7133.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
  7134.  
  7135.     /* Builtin functions */
  7136.     void z_div();
  7137.     integer s_wsfe(), e_wsfe();
  7138.     double z_abs(), sqrt();
  7139.     void d_cnjg();
  7140.     integer do_fio();
  7141.  
  7142.     /* Local variables */
  7143.     static doublereal gmax, c;
  7144.     static integer i, j, k, j1, l1, j2;
  7145.     static doublecomplex y11, y12, y22, yl, zl;
  7146.     extern integer isegno_();
  7147.     extern doublereal db10_();
  7148.     static doublereal dbc;
  7149.     static doublecomplex rho, yin, zin;
  7150.     static integer isg1, isg2, npm1, its1, itt1, itt2, its2;
  7151.  
  7152.     /* Fortran I/O blocks */
  7153.     static cilist io___451 = { 0, 6, 0, fmt_6, 0 };
  7154.     static cilist io___471 = { 0, 6, 0, fmt_7, 0 };
  7155.     static cilist io___472 = { 0, 6, 0, fmt_8, 0 };
  7156.  
  7157.  
  7158. /* *** */
  7159. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  7160.  
  7161. /*     COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS. */
  7162.  
  7163. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  7164. /*<    >*/
  7165. /*<    >*/
  7166. /*<    >*/
  7167. /*<       DIMENSION  CUR(1) >*/
  7168. /*<       IF( NSANT.NE.1.OR. NVQD.NE.0) RETURN >*/
  7169.     /* Parameter adjustments */
  7170.     --cur;
  7171.  
  7172.     /* Function Body */
  7173.     if (vsorc_1.nsant != 1 || vsorc_1.nvqd != 0) {
  7174.     return 0;
  7175.     }
  7176. /*<       J= ISEGNO( NCTAG( ICOUP+1), NCSEG( ICOUP+1)) >*/
  7177.     j = isegno_(&yparm_1.nctag[yparm_1.icoup], &yparm_1.ncseg[yparm_1.icoup]);
  7178.  
  7179. /*<       IF( J.NE. ISANT(1)) RETURN >*/
  7180.     if (j != vsorc_1.isant[0]) {
  7181.     return 0;
  7182.     }
  7183. /*<       ICOUP= ICOUP+1 >*/
  7184.     ++yparm_1.icoup;
  7185. /*<       ZIN= VSANT(1) >*/
  7186.     zin.r = vsorc_1.vsant[0].r, zin.i = vsorc_1.vsant[0].i;
  7187. /*<       Y11A( ICOUP)= CUR( J)* WLAM/ ZIN >*/
  7188.     i__1 = yparm_1.icoup - 1;
  7189.     i__2 = j;
  7190.     z__2.r = *wlam * cur[i__2].r, z__2.i = *wlam * cur[i__2].i;
  7191.     z_div(&z__1, &z__2, &zin);
  7192.     yparm_1.y11a[i__1].r = z__1.r, yparm_1.y11a[i__1].i = z__1.i;
  7193. /*<       L1=( ICOUP-1)*( NCOUP-1) >*/
  7194.     l1 = (yparm_1.icoup - 1) * (yparm_1.ncoup - 1);
  7195. /*<       DO 1  I=1, NCOUP >*/
  7196.     i__1 = yparm_1.ncoup;
  7197.     for (i = 1; i <= i__1; ++i) {
  7198. /*<       IF( I.EQ. ICOUP) GOTO 1 >*/
  7199.     if (i == yparm_1.icoup) {
  7200.         goto L1;
  7201.     }
  7202. /*<       K= ISEGNO( NCTAG( I), NCSEG( I)) >*/
  7203.     k = isegno_(&yparm_1.nctag[i - 1], &yparm_1.ncseg[i - 1]);
  7204. /*<       L1= L1+1 >*/
  7205.     ++l1;
  7206. /*<       Y12A( L1)= CUR( K)* WLAM/ ZIN >*/
  7207.     i__2 = l1 - 1;
  7208.     i__3 = k;
  7209.     z__2.r = *wlam * cur[i__3].r, z__2.i = *wlam * cur[i__3].i;
  7210.     z_div(&z__1, &z__2, &zin);
  7211.     yparm_1.y12a[i__2].r = z__1.r, yparm_1.y12a[i__2].i = z__1.i;
  7212. /*<     1 CONTINUE >*/
  7213. L1:
  7214.     ;
  7215.     }
  7216. /*<       IF( ICOUP.LT. NCOUP) RETURN >*/
  7217.     if (yparm_1.icoup < yparm_1.ncoup) {
  7218.     return 0;
  7219.     }
  7220. /*<       WRITE( 6,6)  >*/
  7221.     s_wsfe(&io___451);
  7222.     e_wsfe();
  7223. /*<       NPM1= NCOUP-1 >*/
  7224.     npm1 = yparm_1.ncoup - 1;
  7225. /*<       DO 5  I=1, NPM1 >*/
  7226.     i__1 = npm1;
  7227.     for (i = 1; i <= i__1; ++i) {
  7228. /*<       ITT1= NCTAG( I) >*/
  7229.     itt1 = yparm_1.nctag[i - 1];
  7230. /*<       ITS1= NCSEG( I) >*/
  7231.     its1 = yparm_1.ncseg[i - 1];
  7232. /*<       ISG1= ISEGNO( ITT1, ITS1) >*/
  7233.     isg1 = isegno_(&itt1, &its1);
  7234. /*<       L1= I+1 >*/
  7235.     l1 = i + 1;
  7236. /*<       DO 5  J= L1, NCOUP >*/
  7237.     i__2 = yparm_1.ncoup;
  7238.     for (j = l1; j <= i__2; ++j) {
  7239. /*<       ITT2= NCTAG( J) >*/
  7240.         itt2 = yparm_1.nctag[j - 1];
  7241. /*<       ITS2= NCSEG( J) >*/
  7242.         its2 = yparm_1.ncseg[j - 1];
  7243. /*<       ISG2= ISEGNO( ITT2, ITS2) >*/
  7244.         isg2 = isegno_(&itt2, &its2);
  7245. /*<       J1= J+( I-1)* NPM1-1 >*/
  7246.         j1 = j + (i - 1) * npm1 - 1;
  7247. /*<       J2= I+( J-1)* NPM1 >*/
  7248.         j2 = i + (j - 1) * npm1;
  7249. /*<       Y11= Y11A( I) >*/
  7250.         i__3 = i - 1;
  7251.         y11.r = yparm_1.y11a[i__3].r, y11.i = yparm_1.y11a[i__3].i;
  7252. /*<       Y22= Y11A( J) >*/
  7253.         i__3 = j - 1;
  7254.         y22.r = yparm_1.y11a[i__3].r, y22.i = yparm_1.y11a[i__3].i;
  7255. /*<       Y12=.5*( Y12A( J1)+ Y12A( J2)) >*/
  7256.         i__3 = j1 - 1;
  7257.         i__4 = j2 - 1;
  7258.         z__2.r = yparm_1.y12a[i__3].r + yparm_1.y12a[i__4].r, z__2.i = 
  7259.             yparm_1.y12a[i__3].i + yparm_1.y12a[i__4].i;
  7260.         z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
  7261.         y12.r = z__1.r, y12.i = z__1.i;
  7262. /*<       YIN= Y12* Y12 >*/
  7263.         z__1.r = y12.r * y12.r - y12.i * y12.i, z__1.i = y12.r * y12.i + 
  7264.             y12.i * y12.r;
  7265.         yin.r = z__1.r, yin.i = z__1.i;
  7266. /*<       DBC= ABS( YIN) >*/
  7267.         dbc = z_abs(&yin);
  7268. /*<       C= DBC/(2.* REAL( Y11)* REAL( Y22)- REAL( YIN)) >*/
  7269.         d__1 = y11.r * 2.;
  7270.         c = dbc / (d__1 * y22.r - yin.r);
  7271. /*<       IF( C.LT.0..OR. C.GT.1.) GOTO 4 >*/
  7272.         if (c < 0. || c > 1.) {
  7273.         goto L4;
  7274.         }
  7275. /*<       IF( C.LT..01) GOTO 2 >*/
  7276.         if (c < .01) {
  7277.         goto L2;
  7278.         }
  7279. /*<       GMAX=(1.- SQRT(1.- C* C))/ C >*/
  7280.         gmax = (1. - sqrt(1. - c * c)) / c;
  7281. /*<       GOTO 3 >*/
  7282.         goto L3;
  7283. /*<     2 GMAX=.5*( C+.25* C* C* C) >*/
  7284. L2:
  7285.         d__2 = c * .25;
  7286.         d__1 = d__2 * c;
  7287.         gmax = (c + d__1 * c) * .5;
  7288. /*<     3 RHO= GMAX* CONJG( YIN)/ DBC >*/
  7289. L3:
  7290.         d_cnjg(&z__3, &yin);
  7291.         z__2.r = gmax * z__3.r, z__2.i = gmax * z__3.i;
  7292.         z__1.r = z__2.r / dbc, z__1.i = z__2.i / dbc;
  7293.         rho.r = z__1.r, rho.i = z__1.i;
  7294. /*<       YL=((1.- RHO)/(1.+ RHO)+1.)* REAL( Y22)- Y22 >*/
  7295.         z__5.r = 1. - rho.r, z__5.i = -rho.i;
  7296.         z__6.r = rho.r + 1., z__6.i = rho.i;
  7297.         z_div(&z__4, &z__5, &z__6);
  7298.         z__3.r = z__4.r + 1., z__3.i = z__4.i;
  7299.         d__1 = y22.r;
  7300.         z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
  7301.         z__1.r = z__2.r - y22.r, z__1.i = z__2.i - y22.i;
  7302.         yl.r = z__1.r, yl.i = z__1.i;
  7303. /*<       ZL=1./ YL >*/
  7304.         z_div(&z__1, &c_b48, &yl);
  7305.         zl.r = z__1.r, zl.i = z__1.i;
  7306. /*<       YIN= Y11- YIN/( Y22+ YL) >*/
  7307.         z__3.r = y22.r + yl.r, z__3.i = y22.i + yl.i;
  7308.         z_div(&z__2, &yin, &z__3);
  7309.         z__1.r = y11.r - z__2.r, z__1.i = y11.i - z__2.i;
  7310.         yin.r = z__1.r, yin.i = z__1.i;
  7311. /*<       ZIN=1./ YIN >*/
  7312.         z_div(&z__1, &c_b48, &yin);
  7313.         zin.r = z__1.r, zin.i = z__1.i;
  7314. /*<       DBC= DB10( GMAX) >*/
  7315.         dbc = db10_(&gmax);
  7316. /*<       WRITE( 6,7)  ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, DBC, ZL, ZIN >*/
  7317.         s_wsfe(&io___471);
  7318.         do_fio(&c__1, (char *)&itt1, (ftnlen)sizeof(integer));
  7319.         do_fio(&c__1, (char *)&its1, (ftnlen)sizeof(integer));
  7320.         do_fio(&c__1, (char *)&isg1, (ftnlen)sizeof(integer));
  7321.         do_fio(&c__1, (char *)&itt2, (ftnlen)sizeof(integer));
  7322.         do_fio(&c__1, (char *)&its2, (ftnlen)sizeof(integer));
  7323.         do_fio(&c__1, (char *)&isg2, (ftnlen)sizeof(integer));
  7324.         do_fio(&c__1, (char *)&dbc, (ftnlen)sizeof(doublereal));
  7325.         do_fio(&c__2, (char *)&zl, (ftnlen)sizeof(doublereal));
  7326.         do_fio(&c__2, (char *)&zin, (ftnlen)sizeof(doublereal));
  7327.         e_wsfe();
  7328. /*<       GOTO 5 >*/
  7329.         goto L5;
  7330. /*<     4 WRITE( 6,8)  ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, C >*/
  7331. L4:
  7332.         s_wsfe(&io___472);
  7333.         do_fio(&c__1, (char *)&itt1, (ftnlen)sizeof(integer));
  7334.         do_fio(&c__1, (char *)&its1, (ftnlen)sizeof(integer));
  7335.         do_fio(&c__1, (char *)&isg1, (ftnlen)sizeof(integer));
  7336.         do_fio(&c__1, (char *)&itt2, (ftnlen)sizeof(integer));
  7337.         do_fio(&c__1, (char *)&its2, (ftnlen)sizeof(integer));
  7338.         do_fio(&c__1, (char *)&isg2, (ftnlen)sizeof(integer));
  7339.         do_fio(&c__1, (char *)&c, (ftnlen)sizeof(doublereal));
  7340.         e_wsfe();
  7341. /*<     5 CONTINUE >*/
  7342. L5:
  7343.         ;
  7344.     }
  7345.     }
  7346.  
  7347. /*<       RETURN >*/
  7348.     return 0;
  7349. /*<    >*/
  7350. /*<     7 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),F9.3,2X,1P,2(2X,E12.5,1X,E12.5)) >*/
  7351. /*<    >*/
  7352. /*<       END >*/
  7353. } /* couple_ */
  7354.  
  7355. /* *** */
  7356. /*     DOUBLE PRECISION 6/4/85 */
  7357.  
  7358. /*<       SUBROUTINE DATAGN >*/
  7359. /* Subroutine */ int datagn_()
  7360. {
  7361.     /* Initialized data */
  7362.  
  7363.     static char atst[2*13+1] = "GWGXGRGSGEGMSPSMGFGASCGCGH";
  7364.     static struct {
  7365.     char e_1[8];
  7366.     integer e_2;
  7367.     } equiv_555 = { {' ', ' ', ' ', ' ', 'X', ' ', ' ', ' '}, 0 };
  7368.  
  7369. #define ifx ((integer *)&equiv_555)
  7370.  
  7371.     static struct {
  7372.     char e_1[8];
  7373.     integer e_2;
  7374.     } equiv_556 = { {' ', ' ', ' ', ' ', 'Y', ' ', ' ', ' '}, 0 };
  7375.  
  7376. #define ify ((integer *)&equiv_556)
  7377.  
  7378.     static struct {
  7379.     char e_1[8];
  7380.     integer e_2;
  7381.     } equiv_557 = { {' ', ' ', ' ', ' ', 'Z', ' ', ' ', ' '}, 0 };
  7382.  
  7383. #define ifz ((integer *)&equiv_557)
  7384.  
  7385.     static doublereal ta = .01745329252;
  7386.     static doublereal td = 57.29577951;
  7387.     static struct {
  7388.     char e_1[16];
  7389.     integer e_2;
  7390.     } equiv_558 = { {'P', ' ', ' ', ' ', 'R', ' ', ' ', ' ', 'T', ' ', 
  7391.         ' ', ' ', 'Q', ' ', ' ', ' '}, 0 };
  7392.  
  7393. #define ipt ((integer *)&equiv_558)
  7394.  
  7395.  
  7396.     /* Format strings */
  7397.     static char fmt_40[] = "(////,33x,\002- - - STRUCTURE SPECIFICATION - \
  7398. - -\002,//,37x,\002COORDINATES MUST BE INPUT IN\002,/,37x,\002METERS OR BE S\
  7399. CALED TO METERS\002,/,37x,\002BEFORE STRUCTURE INPUT IS ENDED\002,//)";
  7400.     static char fmt_41[] = "(2x,\002WIRE\002,79x,\002NO. OF\002,4x,\002FIRS\
  7401. T\002,2x,\002LAST\002,5x,\002TAG\002,/,2x,\002NO.\002,8x,\002X1\002,9x,\002Y1\
  7402. \002,9x,\002Z1\002,10x,\002X2\002,9x,\002Y2\002,9x,\002Z2\002,6x,\002RADIU\
  7403. S\002,3x,\002SEG.\002,5x,\002SEG.\002,3x,\002SEG.\002,5x,\002NO.\002)";
  7404.     static char fmt_43[] = "(1x,i5,3f11.5,1x,4f11.5,2x,i5,4x,i5,1x,i5,3x,i5)";
  7405.  
  7406.     static char fmt_48[] = "(\002 GEOMETRY DATA CARD ERROR\002)";
  7407.     static char fmt_61[] = "(9x,\002ABOVE WIRE IS TAPERED.  SEG. LENGTH RATI\
  7408. O =\002,f9.5,/,33x,\002RADIUS FROM\002,f9.5,\002 TO\002,f9.5)";
  7409.     static char fmt_38[] = "(1x,i5,2x,\002ARC RADIUS =\002,f9.5,2x,\002FRO\
  7410. M\002,f8.3,\002 TO\002,f8.3,\002 DEGREES\002,11x,f11.5,2x,i5,4x,i5,1x,i5,3x,\
  7411. i5)";
  7412.     static char fmt_124[] = "(5x,\002HELIX STRUCTURE-   AXIAL SPACING BETWEE\
  7413. N TURNS =\002,f8.3,\002 TOTAL AXIAL LENGTH =\002,f8.3/1x,i5,2x,\002RADIUS OF\
  7414.  HELIX =\002,4(2x,f8.3),7x,f11.5,i8,4x,i5,1x,i5,3x,i5)";
  7415.     static char fmt_51[] = "(1x,i5,a1,f10.5,2f11.5,1x,3f11.5)";
  7416.     static char fmt_39[] = "(6x,3f11.5,1x,3f11.5)";
  7417.     static char fmt_59[] = "(1x,i5,a1,f10.5,2f11.5,1x,3f11.5,5x,\002SURFAC\
  7418. E -\002,i4,\002 BY\002,i3,\002 PATCHES\002)";
  7419.     static char fmt_60[] = "(\002 PATCH DATA ERROR\002)";
  7420.     static char fmt_44[] = "(6x,\002STRUCTURE REFLECTED ALONG THE AXES\002,3\
  7421. (1x,a1),\002.  TA\002,\002GS INCREMENTED BY\002,i5)";
  7422.     static char fmt_45[] = "(6x,\002STRUCTURE ROTATED ABOUT Z-AXIS\002,i3\
  7423. ,\002 TIMES.  LABELS\002,\002 INCREMENTED BY\002,i5)";
  7424.     static char fmt_46[] = "(6x,\002STRUCTURE SCALED BY FACTOR\002,f10.5)";
  7425.     static char fmt_47[] = "(6x,\002THE STRUCTURE HAS BEEN MOVED, MOVE DATA \
  7426. CARD IS -/6X\002,i3,i5,7f10.5)";
  7427.     static char fmt_52[] = "(\002 ERROR - GF MUST BE FIRST GEOMETRY DATA C\
  7428. ARD\002)";
  7429.     static char fmt_53[] = "(////33x,\002- - - - SEGMENTATION DATA - - - \
  7430. -\002,//,40x,\002COO\002,\002RDINATES IN METERS\002,//,25x,\002I+ AND I- IND\
  7431. ICATE THE SEGMENTS BEFORE AND AFTER I\002,//)";
  7432.     static char fmt_54[] = "(2x,\002SEG.\002,3x,\002COORDINATES OF SEG. CENT\
  7433. ER\002,5x,\002SEG.\002,5x,\002ORIENTATION ANGLES\002,4x,\002WIRE\002,4x,\002\
  7434. CONNECTION DATA\002,3x,\002TAG\002,/,2x,\002NO.\002,7x,\002X\002,9x,\002Y\
  7435. \002,9x,\002Z\002,7x,\002LENGTH\002,5x,\002ALPHA\002,5x,\002BETA\002,6x,\002\
  7436. RADIUS\002,4x,\002I-\002,3x,\002I\002,4x,\002I+\002,4x,\002NO.\002)";
  7437.     static char fmt_55[] = "(1x,i5,4f10.5,1x,3f10.5,1x,3i5,2x,i5)";
  7438.     static char fmt_56[] = "(\002 SEGMENT DATA ERROR\002)";
  7439.     static char fmt_57[] = "(////,44x,\002- - - SURFACE PATCH DATA - - -\002\
  7440. ,//,49x,\002COORD\002,\002INATES IN METERS\002,//,1x,\002PATCH\002,5x,\002CO\
  7441. ORD. OF PATCH CENTER\002,7x,\002UNIT NORMAL VECTOR\002,6x,\002PATCH\002,12x\
  7442. ,\002COMPONENTS OF UNIT TANGENT V'ECTORS\002,/,2x,\002NO.\002,6x,\002X\002,9\
  7443. x,\002Y\002,9x,\002Z\002,9x,\002X\002,7x,\002Y\002,7x,\002Z\002,7x,\002ARE\
  7444. A\002,7x,\002X1\002,6x,\002Y1\002,6x,\002Z1\002,7x,\002X2\002,6x,\002Y2\002,\
  7445. 6x,\002Z2\002)";
  7446.     static char fmt_58[] = "(1x,i4,3f10.5,1x,3f8.4,f10.5,1x,3f8.4,1x,3f8.4)";
  7447.     static char fmt_49[] = "(1x,a2,i3,i5,7f10.5)";
  7448.     static char fmt_50[] = "(\002 NUMBER OF WIRE SEGMENTS AND SURFACE PATCHE\
  7449. S EXCEEDS DI\002,\002MENSION LIMIT.\002)";
  7450.  
  7451.     /* System generated locals */
  7452.     integer i__1;
  7453.     doublereal d__1, d__2;
  7454.  
  7455.     /* Builtin functions */
  7456.     integer s_cmp(), s_wsfe(), e_wsfe(), do_fio();
  7457.     /* Subroutine */ int s_stop();
  7458.     double pow_dd(), sqrt(), asin();
  7459.     integer s_wsle(), do_lio(), e_wsle();
  7460.  
  7461.     /* Local variables */
  7462.     extern /* Subroutine */ int gfil_();
  7463.     static integer iphd, isct;
  7464.     extern /* Subroutine */ int wire_(), move_();
  7465.     extern doublereal atgn2_();
  7466.     static integer i, j;
  7467.     extern /* Subroutine */ int reflc_(), patch_(), helix_();
  7468.     static integer ipsav, nwire, mpsav, npsav, i1, i2;
  7469.     static doublereal dummy;
  7470. #define x2 ((doublereal *)&data_1 + 1800)
  7471. #define y2 ((doublereal *)&data_1 + 3000)
  7472. #define z2 ((doublereal *)&data_1 + 3600)
  7473.     static doublereal x4, y4, z4, x3, y3, z3;
  7474.     static char gm[2];
  7475.     extern /* Subroutine */ int readgm_();
  7476.     static integer ns, ix, iy, iz;
  7477.     extern /* Subroutine */ int conect_();
  7478.     static doublereal xs1;
  7479. #define t1x ((doublereal *)&data_1 + 1800)
  7480. #define t1y ((doublereal *)&data_1 + 3000)
  7481. #define t1z ((doublereal *)&data_1 + 3600)
  7482. #define t2x ((doublereal *)&data_1 + 4201)
  7483. #define t2y ((doublereal *)&data_1 + 4601)
  7484. #define t2z ((doublereal *)&data_1 + 5001)
  7485.     static doublereal xw1, yw1, zw1;
  7486. #define cab ((doublereal *)&data_1 + 3000)
  7487.     static doublereal xw2, yw2, zw2, ys1, zs1, xs2, ys2, zs2;
  7488. #define sab ((doublereal *)&data_1 + 3600)
  7489.     static doublereal rad;
  7490.     extern /* Subroutine */ int arc_();
  7491.     static integer itg;
  7492.  
  7493.     /* Fortran I/O blocks */
  7494.     static cilist io___504 = { 0, 6, 0, fmt_40, 0 };
  7495.     static cilist io___505 = { 0, 6, 0, fmt_41, 0 };
  7496.     static cilist io___508 = { 0, 6, 0, fmt_43, 0 };
  7497.     static cilist io___515 = { 0, 6, 0, fmt_48, 0 };
  7498.     static cilist io___516 = { 0, 6, 0, fmt_61, 0 };
  7499.     static cilist io___517 = { 0, 6, 0, fmt_38, 0 };
  7500.     static cilist io___518 = { 0, 6, 0, fmt_124, 0 };
  7501.     static cilist io___519 = { 0, 6, 0, fmt_51, 0 };
  7502.     static cilist io___529 = { 0, 6, 0, fmt_51, 0 };
  7503.     static cilist io___530 = { 0, 6, 0, fmt_39, 0 };
  7504.     static cilist io___531 = { 0, 6, 0, fmt_59, 0 };
  7505.     static cilist io___532 = { 0, 6, 0, fmt_39, 0 };
  7506.     static cilist io___533 = { 0, 6, 0, fmt_60, 0 };
  7507.     static cilist io___535 = { 0, 6, 0, fmt_44, 0 };
  7508.     static cilist io___536 = { 0, 6, 0, fmt_45, 0 };
  7509.     static cilist io___538 = { 0, 6, 0, fmt_46, 0 };
  7510.     static cilist io___539 = { 0, 6, 0, fmt_47, 0 };
  7511.     static cilist io___540 = { 0, 6, 0, fmt_52, 0 };
  7512.     static cilist io___544 = { 0, 6, 0, fmt_53, 0 };
  7513.     static cilist io___545 = { 0, 6, 0, fmt_54, 0 };
  7514.     static cilist io___546 = { 0, 6, 0, fmt_55, 0 };
  7515.     static cilist io___547 = { 0, 8, 0, 0, 0 };
  7516.     static cilist io___548 = { 0, 6, 0, fmt_56, 0 };
  7517.     static cilist io___549 = { 0, 6, 0, fmt_57, 0 };
  7518.     static cilist io___551 = { 0, 6, 0, fmt_58, 0 };
  7519.     static cilist io___552 = { 0, 6, 0, fmt_48, 0 };
  7520.     static cilist io___553 = { 0, 6, 0, fmt_49, 0 };
  7521.     static cilist io___554 = { 0, 6, 0, fmt_50, 0 };
  7522.  
  7523.  
  7524. /* *** */
  7525. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  7526.  
  7527. /*     DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA. */
  7528.  
  7529. /* *** */
  7530. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  7531. /* *** */
  7532. /*<       CHARACTER *2  GM, ATST >*/
  7533. /* *** */
  7534. /*<    >*/
  7535. /*<       COMMON  /ANGL/ SALP( NM) >*/
  7536. /* *** */
  7537. /*<       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
  7538. /*<    >*/
  7539. /* *** */
  7540. /*<    >*/
  7541. /* *** */
  7542. /*<    >*/
  7543. /*      DATA   ATST/2HGW,2HGX,2HGR,2HGS,2HGE,2HGM,2HSP,2HSM,2HGF,2HGA, */
  7544. /*     &2HSC,2HGC,2HGH/ */
  7545. /*<       DATA   IFX/1H ,1HX/, IFY/1H ,1HY/, IFZ/1H ,1HZ/ >*/
  7546. /*<    >*/
  7547. /*<       IPSYM=0 >*/
  7548.     data_1.ipsym = 0;
  7549. /*<       NWIRE=0 >*/
  7550.     nwire = 0;
  7551. /*<       N=0 >*/
  7552.     data_1.n = 0;
  7553. /*<       NP=0 >*/
  7554.     data_1.np = 0;
  7555. /*<       M=0 >*/
  7556.     data_1.m = 0;
  7557. /*<       MP=0 >*/
  7558.     data_1.mp = 0;
  7559. /*<       N1=0 >*/
  7560.     data_1.n1 = 0;
  7561. /*<       N2=1 >*/
  7562.     data_1.n2 = 1;
  7563. /*<       M1=0 >*/
  7564.     data_1.m1 = 0;
  7565. /*<       M2=1 >*/
  7566.     data_1.m2 = 1;
  7567. /*<       ISCT=0 >*/
  7568.     isct = 0;
  7569.  
  7570. /*     READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION */
  7571. /*     REQUESTED */
  7572.  
  7573. /* *** */
  7574. /* 1     READ (5,42) GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD */
  7575. /*<       IPHD=0 >*/
  7576.     iphd = 0;
  7577. /* *** */
  7578. /*<     1 CALL READGM( GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD) >*/
  7579. L1:
  7580.     readgm_(gm, &itg, &ns, &xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &rad, 2L);
  7581. /*<       IF( N+ M.GT. LD) GOTO 37 >*/
  7582.     if (data_1.n + data_1.m > data_1.ld) {
  7583.     goto L37;
  7584.     }
  7585. /*<       IF( GM.EQ. ATST(9)) GOTO 27 >*/
  7586.     if (s_cmp(gm, atst + 16, 2L, 2L) == 0) {
  7587.     goto L27;
  7588.     }
  7589. /*<       IF( IPHD.EQ.1) GOTO 2 >*/
  7590.     if (iphd == 1) {
  7591.     goto L2;
  7592.     }
  7593. /*<       WRITE( 6,40)  >*/
  7594.     s_wsfe(&io___504);
  7595.     e_wsfe();
  7596. /*<       WRITE( 6,41)  >*/
  7597.     s_wsfe(&io___505);
  7598.     e_wsfe();
  7599. /*<       IPHD=1 >*/
  7600.     iphd = 1;
  7601. /*<     2 IF( GM.EQ. ATST(11)) GOTO 10 >*/
  7602. L2:
  7603.     if (s_cmp(gm, atst + 20, 2L, 2L) == 0) {
  7604.     goto L10;
  7605.     }
  7606. /*<       ISCT=0 >*/
  7607.     isct = 0;
  7608. /*<       IF( GM.EQ. ATST(1)) GOTO 3 >*/
  7609.     if (s_cmp(gm, atst, 2L, 2L) == 0) {
  7610.     goto L3;
  7611.     }
  7612. /*<       IF( GM.EQ. ATST(2)) GOTO 18 >*/
  7613.     if (s_cmp(gm, atst + 2, 2L, 2L) == 0) {
  7614.     goto L18;
  7615.     }
  7616. /*<       IF( GM.EQ. ATST(3)) GOTO 19 >*/
  7617.     if (s_cmp(gm, atst + 4, 2L, 2L) == 0) {
  7618.     goto L19;
  7619.     }
  7620. /*<       IF( GM.EQ. ATST(4)) GOTO 21 >*/
  7621.     if (s_cmp(gm, atst + 6, 2L, 2L) == 0) {
  7622.     goto L21;
  7623.     }
  7624. /*<       IF( GM.EQ. ATST(7)) GOTO 9 >*/
  7625.     if (s_cmp(gm, atst + 12, 2L, 2L) == 0) {
  7626.     goto L9;
  7627.     }
  7628. /*<       IF( GM.EQ. ATST(8)) GOTO 13 >*/
  7629.     if (s_cmp(gm, atst + 14, 2L, 2L) == 0) {
  7630.     goto L13;
  7631.     }
  7632. /*<       IF( GM.EQ. ATST(5)) GOTO 29 >*/
  7633.     if (s_cmp(gm, atst + 8, 2L, 2L) == 0) {
  7634.     goto L29;
  7635.     }
  7636. /*<       IF( GM.EQ. ATST(6)) GOTO 26 >*/
  7637.     if (s_cmp(gm, atst + 10, 2L, 2L) == 0) {
  7638.     goto L26;
  7639.     }
  7640. /* *** */
  7641. /*<       IF( GM.EQ. ATST(10)) GOTO 8 >*/
  7642.     if (s_cmp(gm, atst + 18, 2L, 2L) == 0) {
  7643.     goto L8;
  7644.     }
  7645. /* *** */
  7646. /*<       IF( GM.EQ. ATST(13)) GOTO 123 >*/
  7647.     if (s_cmp(gm, atst + 24, 2L, 2L) == 0) {
  7648.     goto L123;
  7649.     }
  7650.  
  7651. /*     GENERATE SEGMENT DATA FOR STRAIGHT WIRE. */
  7652.  
  7653. /*<       GOTO 36 >*/
  7654.     goto L36;
  7655. /*<     3 NWIRE= NWIRE+1 >*/
  7656. L3:
  7657.     ++nwire;
  7658. /*<       I1= N+1 >*/
  7659.     i1 = data_1.n + 1;
  7660. /*<       I2= N+ NS >*/
  7661.     i2 = data_1.n + ns;
  7662. /*<    >*/
  7663.     s_wsfe(&io___508);
  7664.     do_fio(&c__1, (char *)&nwire, (ftnlen)sizeof(integer));
  7665.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  7666.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  7667.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  7668.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  7669.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  7670.     do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
  7671.     do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
  7672.     do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
  7673.     do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
  7674.     do_fio(&c__1, (char *)&i2, (ftnlen)sizeof(integer));
  7675.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  7676.     e_wsfe();
  7677. /*<       IF( RAD.EQ.0) GOTO 4 >*/
  7678.     if (rad == 0.) {
  7679.     goto L4;
  7680.     }
  7681. /*<       XS1=1. >*/
  7682.     xs1 = 1.;
  7683. /*<       YS1=1. >*/
  7684.     ys1 = 1.;
  7685. /* *** */
  7686. /*<       GOTO 7 >*/
  7687.     goto L7;
  7688. /* 4     READ (5,42) GM,IX,IY,XS1,YS1,ZS1 */
  7689. /* *** */
  7690. /*<    >*/
  7691. L4:
  7692.     readgm_(gm, &ix, &iy, &xs1, &ys1, &zs1, &dummy, &dummy, &dummy, &dummy, 
  7693.         2L);
  7694. /*<       IF( GM.EQ. ATST(12)) GOTO 6 >*/
  7695.     if (s_cmp(gm, atst + 22, 2L, 2L) == 0) {
  7696.     goto L6;
  7697.     }
  7698. /*<     5 WRITE( 6,48)  >*/
  7699. L5:
  7700.     s_wsfe(&io___515);
  7701.     e_wsfe();
  7702. /*<       STOP >*/
  7703.     s_stop("", 0L);
  7704. /*<     6 WRITE( 6,61)  XS1, YS1, ZS1 >*/
  7705. L6:
  7706.     s_wsfe(&io___516);
  7707.     do_fio(&c__1, (char *)&xs1, (ftnlen)sizeof(doublereal));
  7708.     do_fio(&c__1, (char *)&ys1, (ftnlen)sizeof(doublereal));
  7709.     do_fio(&c__1, (char *)&zs1, (ftnlen)sizeof(doublereal));
  7710.     e_wsfe();
  7711. /*<       IF( YS1.EQ.0.OR. ZS1.EQ.0) GOTO 5 >*/
  7712.     if (ys1 == 0. || zs1 == 0.) {
  7713.     goto L5;
  7714.     }
  7715. /*<       RAD= YS1 >*/
  7716.     rad = ys1;
  7717. /*<       YS1=( ZS1/ YS1)**(1./( NS-1.)) >*/
  7718.     d__1 = zs1 / ys1;
  7719.     d__2 = 1. / (ns - 1.);
  7720.     ys1 = pow_dd(&d__1, &d__2);
  7721. /*<     7 CALL WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, XS1, YS1, NS, ITG) >*/
  7722. L7:
  7723.     wire_(&xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &rad, &xs1, &ys1, &ns, &itg);
  7724.  
  7725. /*     GENERATE SEGMENT DATA FOR WIRE ARC */
  7726.  
  7727. /*<       GOTO 1 >*/
  7728.     goto L1;
  7729. /*<     8 NWIRE= NWIRE+1 >*/
  7730. L8:
  7731.     ++nwire;
  7732. /*<       I1= N+1 >*/
  7733.     i1 = data_1.n + 1;
  7734. /*<       I2= N+ NS >*/
  7735.     i2 = data_1.n + ns;
  7736. /*<       WRITE( 6,38)  NWIRE, XW1, YW1, ZW1, XW2, NS, I1, I2, ITG >*/
  7737.     s_wsfe(&io___517);
  7738.     do_fio(&c__1, (char *)&nwire, (ftnlen)sizeof(integer));
  7739.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  7740.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  7741.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  7742.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  7743.     do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
  7744.     do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
  7745.     do_fio(&c__1, (char *)&i2, (ftnlen)sizeof(integer));
  7746.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  7747.     e_wsfe();
  7748. /*<       CALL ARC( ITG, NS, XW1, YW1, ZW1, XW2) >*/
  7749.     arc_(&itg, &ns, &xw1, &yw1, &zw1, &xw2);
  7750. /* *** */
  7751.  
  7752. /*     GENERATE HELIX */
  7753.  
  7754. /*<       GOTO 1 >*/
  7755.     goto L1;
  7756. /*<   123 NWIRE= NWIRE+1 >*/
  7757. L123:
  7758.     ++nwire;
  7759. /*<       I1= N+1 >*/
  7760.     i1 = data_1.n + 1;
  7761. /*<       I2= N+ NS >*/
  7762.     i2 = data_1.n + ns;
  7763. /*<    >*/
  7764.     s_wsfe(&io___518);
  7765.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  7766.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  7767.     do_fio(&c__1, (char *)&nwire, (ftnlen)sizeof(integer));
  7768.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  7769.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  7770.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  7771.     do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
  7772.     do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
  7773.     do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
  7774.     do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
  7775.     do_fio(&c__1, (char *)&i2, (ftnlen)sizeof(integer));
  7776.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  7777.     e_wsfe();
  7778. /*<       CALL HELIX( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, ITG) >*/
  7779.     helix_(&xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &rad, &ns, &itg);
  7780.  
  7781. /*<       GOTO 1 >*/
  7782.     goto L1;
  7783. /* *** */
  7784.  
  7785. /*     GENERATE SINGLE NEW PATCH */
  7786.  
  7787. /*<    >*/
  7788. /*<     9 I1= M+1 >*/
  7789. L9:
  7790.     i1 = data_1.m + 1;
  7791. /*<       NS= NS+1 >*/
  7792.     ++ns;
  7793. /*<       IF( ITG.NE.0) GOTO 17 >*/
  7794.     if (itg != 0) {
  7795.     goto L17;
  7796.     }
  7797. /*<       WRITE( 6,51)  I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2 >*/
  7798.     s_wsfe(&io___519);
  7799.     do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
  7800.     do_fio(&c__1, (char *)&ipt[ns - 1], (ftnlen)sizeof(integer));
  7801.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  7802.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  7803.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  7804.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  7805.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  7806.     do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
  7807.     e_wsfe();
  7808. /*<       IF( NS.EQ.2.OR. NS.EQ.4) ISCT=1 >*/
  7809.     if (ns == 2 || ns == 4) {
  7810.     isct = 1;
  7811.     }
  7812. /*<       IF( NS.GT.1) GOTO 14 >*/
  7813.     if (ns > 1) {
  7814.     goto L14;
  7815.     }
  7816. /*<       XW2= XW2* TA >*/
  7817.     xw2 *= ta;
  7818. /*<       YW2= YW2* TA >*/
  7819.     yw2 *= ta;
  7820. /*<       GOTO 16 >*/
  7821.     goto L16;
  7822. /*<    10 IF( ISCT.EQ.0) GOTO 17 >*/
  7823. L10:
  7824.     if (isct == 0) {
  7825.     goto L17;
  7826.     }
  7827. /*<       I1= M+1 >*/
  7828.     i1 = data_1.m + 1;
  7829. /*<       NS= NS+1 >*/
  7830.     ++ns;
  7831. /*<       IF( ITG.NE.0) GOTO 17 >*/
  7832.     if (itg != 0) {
  7833.     goto L17;
  7834.     }
  7835. /*<       IF( NS.NE.2.AND. NS.NE.4) GOTO 17 >*/
  7836.     if (ns != 2 && ns != 4) {
  7837.     goto L17;
  7838.     }
  7839. /*<       XS1= X4 >*/
  7840.     xs1 = x4;
  7841. /*<       YS1= Y4 >*/
  7842.     ys1 = y4;
  7843. /*<       ZS1= Z4 >*/
  7844.     zs1 = z4;
  7845. /*<       XS2= X3 >*/
  7846.     xs2 = x3;
  7847. /*<       YS2= Y3 >*/
  7848.     ys2 = y3;
  7849. /*<       ZS2= Z3 >*/
  7850.     zs2 = z3;
  7851. /*<       X3= XW1 >*/
  7852.     x3 = xw1;
  7853. /*<       Y3= YW1 >*/
  7854.     y3 = yw1;
  7855. /*<       Z3= ZW1 >*/
  7856.     z3 = zw1;
  7857. /*<       IF( NS.NE.4) GOTO 11 >*/
  7858.     if (ns != 4) {
  7859.     goto L11;
  7860.     }
  7861. /*<       X4= XW2 >*/
  7862.     x4 = xw2;
  7863. /*<       Y4= YW2 >*/
  7864.     y4 = yw2;
  7865. /*<       Z4= ZW2 >*/
  7866.     z4 = zw2;
  7867. /*<    11 XW1= XS1 >*/
  7868. L11:
  7869.     xw1 = xs1;
  7870. /*<       YW1= YS1 >*/
  7871.     yw1 = ys1;
  7872. /*<       ZW1= ZS1 >*/
  7873.     zw1 = zs1;
  7874. /*<       XW2= XS2 >*/
  7875.     xw2 = xs2;
  7876. /*<       YW2= YS2 >*/
  7877.     yw2 = ys2;
  7878. /*<       ZW2= ZS2 >*/
  7879.     zw2 = zs2;
  7880. /*<       IF( NS.EQ.4) GOTO 12 >*/
  7881.     if (ns == 4) {
  7882.     goto L12;
  7883.     }
  7884. /*<       X4= XW1+ X3- XW2 >*/
  7885.     x4 = xw1 + x3 - xw2;
  7886. /*<       Y4= YW1+ Y3- YW2 >*/
  7887.     y4 = yw1 + y3 - yw2;
  7888. /*<       Z4= ZW1+ Z3- ZW2 >*/
  7889.     z4 = zw1 + z3 - zw2;
  7890. /*<    12 WRITE( 6,51)  I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2 >*/
  7891. L12:
  7892.     s_wsfe(&io___529);
  7893.     do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
  7894.     do_fio(&c__1, (char *)&ipt[ns - 1], (ftnlen)sizeof(integer));
  7895.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  7896.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  7897.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  7898.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  7899.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  7900.     do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
  7901.     e_wsfe();
  7902. /*<       WRITE( 6,39)  X3, Y3, Z3, X4, Y4, Z4 >*/
  7903.     s_wsfe(&io___530);
  7904.     do_fio(&c__1, (char *)&x3, (ftnlen)sizeof(doublereal));
  7905.     do_fio(&c__1, (char *)&y3, (ftnlen)sizeof(doublereal));
  7906.     do_fio(&c__1, (char *)&z3, (ftnlen)sizeof(doublereal));
  7907.     do_fio(&c__1, (char *)&x4, (ftnlen)sizeof(doublereal));
  7908.     do_fio(&c__1, (char *)&y4, (ftnlen)sizeof(doublereal));
  7909.     do_fio(&c__1, (char *)&z4, (ftnlen)sizeof(doublereal));
  7910.     e_wsfe();
  7911.  
  7912. /*     GENERATE MULTIPLE-PATCH SURFACE */
  7913.  
  7914. /*<       GOTO 16 >*/
  7915.     goto L16;
  7916. /*<    13 I1= M+1 >*/
  7917. L13:
  7918.     i1 = data_1.m + 1;
  7919. /*<       WRITE( 6,59)  I1, IPT(2), XW1, YW1, ZW1, XW2, YW2, ZW2, ITG, NS >*/
  7920.     s_wsfe(&io___531);
  7921.     do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
  7922.     do_fio(&c__1, (char *)&ipt[1], (ftnlen)sizeof(integer));
  7923.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  7924.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  7925.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  7926.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  7927.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  7928.     do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
  7929.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  7930.     do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
  7931.     e_wsfe();
  7932. /* *** */
  7933. /*<       IF( ITG.LT.1.OR. NS.LT.1) GOTO 17 >*/
  7934.     if (itg < 1 || ns < 1) {
  7935.     goto L17;
  7936.     }
  7937. /* 14    READ (5,42) GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4 */
  7938. /* *** */
  7939. /*<    14 CALL READGM( GM, IX, IY, X3, Y3, Z3, X4, Y4, Z4, DUMMY) >*/
  7940. L14:
  7941.     readgm_(gm, &ix, &iy, &x3, &y3, &z3, &x4, &y4, &z4, &dummy, 2L);
  7942. /*<       IF( NS.NE.2.AND. ITG.LT.1) GOTO 15 >*/
  7943.     if (ns != 2 && itg < 1) {
  7944.     goto L15;
  7945.     }
  7946. /*<       X4= XW1+ X3- XW2 >*/
  7947.     x4 = xw1 + x3 - xw2;
  7948. /*<       Y4= YW1+ Y3- YW2 >*/
  7949.     y4 = yw1 + y3 - yw2;
  7950. /*<       Z4= ZW1+ Z3- ZW2 >*/
  7951.     z4 = zw1 + z3 - zw2;
  7952. /*<    15 WRITE( 6,39)  X3, Y3, Z3, X4, Y4, Z4 >*/
  7953. L15:
  7954.     s_wsfe(&io___532);
  7955.     do_fio(&c__1, (char *)&x3, (ftnlen)sizeof(doublereal));
  7956.     do_fio(&c__1, (char *)&y3, (ftnlen)sizeof(doublereal));
  7957.     do_fio(&c__1, (char *)&z3, (ftnlen)sizeof(doublereal));
  7958.     do_fio(&c__1, (char *)&x4, (ftnlen)sizeof(doublereal));
  7959.     do_fio(&c__1, (char *)&y4, (ftnlen)sizeof(doublereal));
  7960.     do_fio(&c__1, (char *)&z4, (ftnlen)sizeof(doublereal));
  7961.     e_wsfe();
  7962. /*<       IF( GM.NE. ATST(11)) GOTO 17 >*/
  7963.     if (s_cmp(gm, atst + 20, 2L, 2L) != 0) {
  7964.     goto L17;
  7965.     }
  7966. /*<    >*/
  7967. L16:
  7968.     patch_(&itg, &ns, &xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &x3, &y3, &z3, &x4, 
  7969.         &y4, &z4);
  7970. /*<       GOTO 1 >*/
  7971.     goto L1;
  7972. /*<    17 WRITE( 6,60)  >*/
  7973. L17:
  7974.     s_wsfe(&io___533);
  7975.     e_wsfe();
  7976.  
  7977. /*     REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER. 
  7978. */
  7979.  
  7980. /*<       STOP >*/
  7981.     s_stop("", 0L);
  7982. /*<    18 IY= NS/10 >*/
  7983. L18:
  7984.     iy = ns / 10;
  7985. /*<       IZ= NS- IY*10 >*/
  7986.     iz = ns - iy * 10;
  7987. /*<       IX= IY/10 >*/
  7988.     ix = iy / 10;
  7989. /*<       IY= IY- IX*10 >*/
  7990.     iy -= ix * 10;
  7991. /*<       IF( IX.NE.0) IX=1 >*/
  7992.     if (ix != 0) {
  7993.     ix = 1;
  7994.     }
  7995. /*<       IF( IY.NE.0) IY=1 >*/
  7996.     if (iy != 0) {
  7997.     iy = 1;
  7998.     }
  7999. /*<       IF( IZ.NE.0) IZ=1 >*/
  8000.     if (iz != 0) {
  8001.     iz = 1;
  8002.     }
  8003. /*<       WRITE( 6,44)  IFX( IX+1), IFY( IY+1), IFZ( IZ+1), ITG >*/
  8004.     s_wsfe(&io___535);
  8005.     do_fio(&c__1, (char *)&ifx[ix], (ftnlen)sizeof(integer));
  8006.     do_fio(&c__1, (char *)&ify[iy], (ftnlen)sizeof(integer));
  8007.     do_fio(&c__1, (char *)&ifz[iz], (ftnlen)sizeof(integer));
  8008.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  8009.     e_wsfe();
  8010. /*<       GOTO 20 >*/
  8011.     goto L20;
  8012. /*<    19 WRITE( 6,45)  NS, ITG >*/
  8013. L19:
  8014.     s_wsfe(&io___536);
  8015.     do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
  8016.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  8017.     e_wsfe();
  8018. /*<       IX=-1 >*/
  8019.     ix = -1;
  8020. /*<    20 CALL REFLC( IX, IY, IZ, ITG, NS) >*/
  8021. L20:
  8022.     reflc_(&ix, &iy, &iz, &itg, &ns);
  8023.  
  8024. /*     SCALE STRUCTURE DIMENSIONS BY FACTOR XW1. */
  8025.  
  8026. /*<       GOTO 1 >*/
  8027.     goto L1;
  8028. /*<    21 IF( N.LT. N2) GOTO 23 >*/
  8029. L21:
  8030.     if (data_1.n < data_1.n2) {
  8031.     goto L23;
  8032.     }
  8033. /*<       DO 22  I= N2, N >*/
  8034.     i__1 = data_1.n;
  8035.     for (i = data_1.n2; i <= i__1; ++i) {
  8036. /*<       X( I)= X( I)* XW1 >*/
  8037.     data_1.x[i - 1] *= xw1;
  8038. /*<       Y( I)= Y( I)* XW1 >*/
  8039.     data_1.y[i - 1] *= xw1;
  8040. /*<       Z( I)= Z( I)* XW1 >*/
  8041.     data_1.z[i - 1] *= xw1;
  8042. /*<       X2( I)= X2( I)* XW1 >*/
  8043.     x2[i - 1] *= xw1;
  8044. /*<       Y2( I)= Y2( I)* XW1 >*/
  8045.     y2[i - 1] *= xw1;
  8046. /*<       Z2( I)= Z2( I)* XW1 >*/
  8047.     z2[i - 1] *= xw1;
  8048. /*<    22 BI( I)= BI( I)* XW1 >*/
  8049. /* L22: */
  8050.     data_1.bi[i - 1] *= xw1;
  8051.     }
  8052. /*<    23 IF( M.LT. M2) GOTO 25 >*/
  8053. L23:
  8054.     if (data_1.m < data_1.m2) {
  8055.     goto L25;
  8056.     }
  8057. /*<       YW1= XW1* XW1 >*/
  8058.     yw1 = xw1 * xw1;
  8059. /*<       IX= LD+1- M >*/
  8060.     ix = data_1.ld + 1 - data_1.m;
  8061. /*<       IY= LD- M1 >*/
  8062.     iy = data_1.ld - data_1.m1;
  8063. /*<       DO 24  I= IX, IY >*/
  8064.     i__1 = iy;
  8065.     for (i = ix; i <= i__1; ++i) {
  8066. /*<       X( I)= X( I)* XW1 >*/
  8067.     data_1.x[i - 1] *= xw1;
  8068. /*<       Y( I)= Y( I)* XW1 >*/
  8069.     data_1.y[i - 1] *= xw1;
  8070. /*<       Z( I)= Z( I)* XW1 >*/
  8071.     data_1.z[i - 1] *= xw1;
  8072. /*<    24 BI( I)= BI( I)* YW1 >*/
  8073. /* L24: */
  8074.     data_1.bi[i - 1] *= yw1;
  8075.     }
  8076. /*<    25 WRITE( 6,46)  XW1 >*/
  8077. L25:
  8078.     s_wsfe(&io___538);
  8079.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  8080.     e_wsfe();
  8081.  
  8082. /*     MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS. */
  8083.  
  8084.  
  8085. /*<       GOTO 1 >*/
  8086.     goto L1;
  8087. /*<    26 WRITE( 6,47)  ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD >*/
  8088. L26:
  8089.     s_wsfe(&io___539);
  8090.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  8091.     do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
  8092.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  8093.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  8094.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  8095.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  8096.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  8097.     do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
  8098.     do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
  8099.     e_wsfe();
  8100. /*<       XW1= XW1* TA >*/
  8101.     xw1 *= ta;
  8102. /*<       YW1= YW1* TA >*/
  8103.     yw1 *= ta;
  8104. /*<       ZW1= ZW1* TA >*/
  8105.     zw1 *= ta;
  8106. /*<       CALL MOVE( XW1, YW1, ZW1, XW2, YW2, ZW2, INT( RAD+.5), NS, ITG) >*/
  8107.     i__1 = (integer) (rad + .5);
  8108.     move_(&xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &i__1, &ns, &itg);
  8109.  
  8110. /*     READ NUMERICAL GREEN'S FUNCTION TAPE */
  8111.  
  8112. /*<       GOTO 1 >*/
  8113.     goto L1;
  8114. /*<    27 IF( N+ M.EQ.0) GOTO 28 >*/
  8115. L27:
  8116.     if (data_1.n + data_1.m == 0) {
  8117.     goto L28;
  8118.     }
  8119. /*<       WRITE( 6,52)  >*/
  8120.     s_wsfe(&io___540);
  8121.     e_wsfe();
  8122. /*<       STOP >*/
  8123.     s_stop("", 0L);
  8124. /*<    28 CALL GFIL( ITG) >*/
  8125. L28:
  8126.     gfil_(&itg);
  8127. /*<       NPSAV= NP >*/
  8128.     npsav = data_1.np;
  8129. /*<       MPSAV= MP >*/
  8130.     mpsav = data_1.mp;
  8131. /*<       IPSAV= IPSYM >*/
  8132.     ipsav = data_1.ipsym;
  8133.  
  8134. /*     TERMINATE STRUCTURE GEOMETRY INPUT. */
  8135.  
  8136. /* *** */
  8137. /*<       GOTO 1 >*/
  8138.     goto L1;
  8139. /*<    29 IF( NS.EQ.0) GOTO 290 >*/
  8140. L29:
  8141.     if (ns == 0) {
  8142.     goto L290;
  8143.     }
  8144. /*<       IPLP1=1 >*/
  8145.     plot_1.iplp1 = 1;
  8146. /*<       IPLP2=1 >*/
  8147.     plot_1.iplp2 = 1;
  8148. /* *** */
  8149. /*<   290 IX= N1+ M1 >*/
  8150. L290:
  8151.     ix = data_1.n1 + data_1.m1;
  8152. /*<       IF( IX.EQ.0) GOTO 30 >*/
  8153.     if (ix == 0) {
  8154.     goto L30;
  8155.     }
  8156. /*<       NP= N >*/
  8157.     data_1.np = data_1.n;
  8158. /*<       MP= M >*/
  8159.     data_1.mp = data_1.m;
  8160. /*<       IPSYM=0 >*/
  8161.     data_1.ipsym = 0;
  8162. /*<    30 CALL CONECT( ITG) >*/
  8163. L30:
  8164.     conect_(&itg);
  8165. /*<       IF( IX.EQ.0) GOTO 31 >*/
  8166.     if (ix == 0) {
  8167.     goto L31;
  8168.     }
  8169. /*<       NP= NPSAV >*/
  8170.     data_1.np = npsav;
  8171. /*<       MP= MPSAV >*/
  8172.     data_1.mp = mpsav;
  8173. /*<       IPSYM= IPSAV >*/
  8174.     data_1.ipsym = ipsav;
  8175. /*<    31 IF( N+ M.GT. LD) GOTO 37 >*/
  8176. L31:
  8177.     if (data_1.n + data_1.m > data_1.ld) {
  8178.     goto L37;
  8179.     }
  8180. /*<       IF( N.EQ.0) GOTO 33 >*/
  8181.     if (data_1.n == 0) {
  8182.     goto L33;
  8183.     }
  8184. /*<       WRITE( 6,53)  >*/
  8185.     s_wsfe(&io___544);
  8186.     e_wsfe();
  8187. /*<       WRITE( 6,54)  >*/
  8188.     s_wsfe(&io___545);
  8189.     e_wsfe();
  8190. /*<       DO 32  I=1, N >*/
  8191.     i__1 = data_1.n;
  8192.     for (i = 1; i <= i__1; ++i) {
  8193. /*<       XW1= X2( I)- X( I) >*/
  8194.     xw1 = x2[i - 1] - data_1.x[i - 1];
  8195. /*<       YW1= Y2( I)- Y( I) >*/
  8196.     yw1 = y2[i - 1] - data_1.y[i - 1];
  8197. /*<       ZW1= Z2( I)- Z( I) >*/
  8198.     zw1 = z2[i - 1] - data_1.z[i - 1];
  8199. /*<       X( I)=( X( I)+ X2( I))*.5 >*/
  8200.     data_1.x[i - 1] = (data_1.x[i - 1] + x2[i - 1]) * .5;
  8201. /*<       Y( I)=( Y( I)+ Y2( I))*.5 >*/
  8202.     data_1.y[i - 1] = (data_1.y[i - 1] + y2[i - 1]) * .5;
  8203. /*<       Z( I)=( Z( I)+ Z2( I))*.5 >*/
  8204.     data_1.z[i - 1] = (data_1.z[i - 1] + z2[i - 1]) * .5;
  8205. /*<       XW2= XW1* XW1+ YW1* YW1+ ZW1* ZW1 >*/
  8206.     d__1 = xw1 * xw1 + yw1 * yw1;
  8207.     xw2 = d__1 + zw1 * zw1;
  8208. /*<       YW2= SQRT( XW2) >*/
  8209.     yw2 = sqrt(xw2);
  8210. /*<       YW2=( XW2/ YW2+ YW2)*.5 >*/
  8211.     yw2 = (xw2 / yw2 + yw2) * .5;
  8212. /*<       SI( I)= YW2 >*/
  8213.     data_1.si[i - 1] = yw2;
  8214. /*<       CAB( I)= XW1/ YW2 >*/
  8215.     cab[i - 1] = xw1 / yw2;
  8216. /*<       SAB( I)= YW1/ YW2 >*/
  8217.     sab[i - 1] = yw1 / yw2;
  8218. /*<       XW2= ZW1/ YW2 >*/
  8219.     xw2 = zw1 / yw2;
  8220. /*<       IF( XW2.GT.1.) XW2=1. >*/
  8221.     if (xw2 > 1.) {
  8222.         xw2 = 1.;
  8223.     }
  8224. /*<       IF( XW2.LT.-1.) XW2=-1. >*/
  8225.     if (xw2 < -1.) {
  8226.         xw2 = -1.;
  8227.     }
  8228. /*<       SALP( I)= XW2 >*/
  8229.     angl_1.salp[i - 1] = xw2;
  8230. /*<       XW2= ASIN( XW2)* TD >*/
  8231.     xw2 = asin(xw2) * td;
  8232. /*<       YW2= ATGN2( YW1, XW1)* TD >*/
  8233.     yw2 = atgn2_(&yw1, &xw1) * td;
  8234. /* *** */
  8235. /*<    >*/
  8236.     s_wsfe(&io___546);
  8237.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  8238.     do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  8239.     do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  8240.     do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  8241.     do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  8242.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  8243.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  8244.     do_fio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
  8245.     do_fio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
  8246.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  8247.     do_fio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
  8248.     do_fio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
  8249.     e_wsfe();
  8250. /*<       IF( IPLP1.NE.1) GOTO 320 >*/
  8251.     if (plot_1.iplp1 != 1) {
  8252.         goto L320;
  8253.     }
  8254. /*<    >*/
  8255.     s_wsle(&io___547);
  8256.     do_lio(&c__5, &c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(
  8257.         doublereal));
  8258.     do_lio(&c__5, &c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(
  8259.         doublereal));
  8260.     do_lio(&c__5, &c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(
  8261.         doublereal));
  8262.     do_lio(&c__5, &c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(
  8263.         doublereal));
  8264.     do_lio(&c__5, &c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  8265.     do_lio(&c__5, &c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  8266.     do_lio(&c__5, &c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(
  8267.         doublereal));
  8268.     do_lio(&c__3, &c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(
  8269.         integer));
  8270.     do_lio(&c__3, &c__1, (char *)&i, (ftnlen)sizeof(integer));
  8271.     do_lio(&c__3, &c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(
  8272.         integer));
  8273.     e_wsle();
  8274. /* *** */
  8275. /*<   320 CONTINUE >*/
  8276. L320:
  8277. /*<       IF( SI( I).GT.1.D-20.AND. BI( I).GT.0.) GOTO 32 >*/
  8278.     if (data_1.si[i - 1] > 1e-20 && data_1.bi[i - 1] > 0.) {
  8279.         goto L32;
  8280.     }
  8281. /*<       WRITE( 6,56)  >*/
  8282.     s_wsfe(&io___548);
  8283.     e_wsfe();
  8284. /*<       STOP >*/
  8285.     s_stop("", 0L);
  8286. /*<    32 CONTINUE >*/
  8287. L32:
  8288.     ;
  8289.     }
  8290. /*<    33 IF( M.EQ.0) GOTO 35 >*/
  8291. L33:
  8292.     if (data_1.m == 0) {
  8293.     goto L35;
  8294.     }
  8295. /*<       WRITE( 6,57)  >*/
  8296.     s_wsfe(&io___549);
  8297.     e_wsfe();
  8298. /*<       J= LD+1 >*/
  8299.     j = data_1.ld + 1;
  8300. /*<       DO 34  I=1, M >*/
  8301.     i__1 = data_1.m;
  8302.     for (i = 1; i <= i__1; ++i) {
  8303. /*<       J= J-1 >*/
  8304.     --j;
  8305. /*<       XW1=( T1Y( J)* T2Z( J)- T1Z( J)* T2Y( J))* SALP( J) >*/
  8306.     xw1 = (t1y[j - 1] * t2z[j - 1] - t1z[j - 1] * t2y[j - 1]) * 
  8307.         angl_1.salp[j - 1];
  8308. /*<       YW1=( T1Z( J)* T2X( J)- T1X( J)* T2Z( J))* SALP( J) >*/
  8309.     yw1 = (t1z[j - 1] * t2x[j - 1] - t1x[j - 1] * t2z[j - 1]) * 
  8310.         angl_1.salp[j - 1];
  8311. /*<       ZW1=( T1X( J)* T2Y( J)- T1Y( J)* T2X( J))* SALP( J) >*/
  8312.     zw1 = (t1x[j - 1] * t2y[j - 1] - t1y[j - 1] * t2x[j - 1]) * 
  8313.         angl_1.salp[j - 1];
  8314. /*<    >*/
  8315.     s_wsfe(&io___551);
  8316.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  8317.     do_fio(&c__1, (char *)&data_1.x[j - 1], (ftnlen)sizeof(doublereal));
  8318.     do_fio(&c__1, (char *)&data_1.y[j - 1], (ftnlen)sizeof(doublereal));
  8319.     do_fio(&c__1, (char *)&data_1.z[j - 1], (ftnlen)sizeof(doublereal));
  8320.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  8321.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  8322.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  8323.     do_fio(&c__1, (char *)&data_1.bi[j - 1], (ftnlen)sizeof(doublereal));
  8324.     do_fio(&c__1, (char *)&t1x[j - 1], (ftnlen)sizeof(doublereal));
  8325.     do_fio(&c__1, (char *)&t1y[j - 1], (ftnlen)sizeof(doublereal));
  8326.     do_fio(&c__1, (char *)&t1z[j - 1], (ftnlen)sizeof(doublereal));
  8327.     do_fio(&c__1, (char *)&t2x[j - 1], (ftnlen)sizeof(doublereal));
  8328.     do_fio(&c__1, (char *)&t2y[j - 1], (ftnlen)sizeof(doublereal));
  8329.     do_fio(&c__1, (char *)&t2z[j - 1], (ftnlen)sizeof(doublereal));
  8330.     e_wsfe();
  8331. /*<    34 CONTINUE >*/
  8332. /* L34: */
  8333.     }
  8334. /*<    35 RETURN >*/
  8335. L35:
  8336.     return 0;
  8337. /*<    36 WRITE( 6,48)  >*/
  8338. L36:
  8339.     s_wsfe(&io___552);
  8340.     e_wsfe();
  8341. /*<       WRITE( 6,49)  GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD >*/
  8342.     s_wsfe(&io___553);
  8343.     do_fio(&c__1, gm, 2L);
  8344.     do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
  8345.     do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
  8346.     do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
  8347.     do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
  8348.     do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
  8349.     do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
  8350.     do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
  8351.     do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
  8352.     do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
  8353.     e_wsfe();
  8354. /*<       STOP >*/
  8355.     s_stop("", 0L);
  8356. /*<    37 WRITE( 6,50)  >*/
  8357. L37:
  8358.     s_wsfe(&io___554);
  8359.     e_wsfe();
  8360.  
  8361. /*<       STOP >*/
  8362.     s_stop("", 0L);
  8363. /*<    >*/
  8364. /*<    39 FORMAT(6X,3F11.5,1X,3F11.5) >*/
  8365. /*<    >*/
  8366. /*<    >*/
  8367. /*<    42 FORMAT(A2, I3, I5, 7F10.5) >*/
  8368. /* L42: */
  8369. /*<    43 FORMAT(1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5) >*/
  8370. /*<    >*/
  8371. /*<    >*/
  8372. /*<    46 FORMAT(6X,'STRUCTURE SCALED BY FACTOR',F10.5) >*/
  8373. /*<    >*/
  8374. /*<    48 FORMAT(' GEOMETRY DATA CARD ERROR') >*/
  8375. /*<    49 FORMAT(1X,A2,I3,I5,7F10.5) >*/
  8376. /*<    >*/
  8377. /*<    51 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5) >*/
  8378. /*<    52 FORMAT(' ERROR - GF MUST BE FIRST GEOMETRY DATA CARD') >*/
  8379. /*<    >*/
  8380. /*<    >*/
  8381. /*<    55 FORMAT(1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5) >*/
  8382. /*<    56 FORMAT(' SEGMENT DATA ERROR') >*/
  8383. /*<    >*/
  8384. /*<    58 FORMAT(1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4) >*/
  8385. /*<    >*/
  8386. /*<    60 FORMAT(' PATCH DATA ERROR') >*/
  8387. /*<    >*/
  8388. /*<       END >*/
  8389. } /* datagn_ */
  8390.  
  8391. #undef sab
  8392. #undef cab
  8393. #undef t2z
  8394. #undef t2y
  8395. #undef t2x
  8396. #undef t1z
  8397. #undef t1y
  8398. #undef t1x
  8399. #undef z2
  8400. #undef y2
  8401. #undef x2
  8402. #undef ipt
  8403. #undef ifz
  8404. #undef ify
  8405. #undef ifx
  8406.  
  8407.  
  8408. /* *** */
  8409. /*     DOUBLE PRECISION 6/4/85 */
  8410.  
  8411. /*<       FUNCTION DB10( X) >*/
  8412. doublereal db10_0_(n__, x)
  8413. int n__;
  8414. doublereal *x;
  8415. {
  8416.     /* System generated locals */
  8417.     doublereal ret_val;
  8418.  
  8419.     /* Builtin functions */
  8420.     double d_lg10();
  8421.  
  8422.     /* Local variables */
  8423.     static doublereal f;
  8424.  
  8425. /* *** */
  8426.  
  8427. /*     FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I 
  8428. */
  8429.  
  8430. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  8431. /*<       F=10. >*/
  8432.     switch(n__) {
  8433.     case 1: goto L_db20;
  8434.     }
  8435.  
  8436.     f = 10.;
  8437. /*<       GOTO 1 >*/
  8438.     goto L1;
  8439. /*<       ENTRY DB20 (x) >*/
  8440.  
  8441. L_db20:
  8442. /*<       F=20. >*/
  8443.     f = 20.;
  8444. /*<     1 IF( X.LT.1.D-20) GOTO 2 >*/
  8445. L1:
  8446.     if (*x < 1e-20) {
  8447.     goto L2;
  8448.     }
  8449. /*<       DB10= F* LOG10( X) >*/
  8450.     ret_val = f * d_lg10(x);
  8451. /*<       RETURN >*/
  8452.     return ret_val;
  8453. /*<     2 DB10=-999.99 >*/
  8454. L2:
  8455.     ret_val = -999.99;
  8456. /*<       RETURN >*/
  8457.     return ret_val;
  8458. /*<       END >*/
  8459. } /* db10_ */
  8460.  
  8461. doublereal db10_(x)
  8462. doublereal *x;
  8463. {
  8464.     return db10_0_(0, x);
  8465.     }
  8466.  
  8467. doublereal db20_(x)
  8468. doublereal *x;
  8469. {
  8470.     return db10_0_(1, x);
  8471.     }
  8472.  
  8473. /* *** */
  8474. /*     DOUBLE PRECISION 6/4/85 */
  8475.  
  8476. /*<       SUBROUTINE EFLD( XI, YI, ZI, AI, IJ) >*/
  8477. /* Subroutine */ int efld_(xi, yi, zi, ai, ij)
  8478. doublereal *xi, *yi, *zi, *ai;
  8479. integer *ij;
  8480. {
  8481.     /* Initialized data */
  8482.  
  8483.     static doublereal eta = 376.73;
  8484.     static doublereal pi = 3.141592654;
  8485.     static doublereal tp = 6.283185308;
  8486.  
  8487.     /* System generated locals */
  8488.     integer i__1;
  8489.     doublereal d__1, d__2, d__3;
  8490.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
  8491.     static doublecomplex equiv_8[9];
  8492.  
  8493.     /* Builtin functions */
  8494.     double sqrt(), cos(), sin(), log();
  8495.     void z_div(), z_sqrt(), d_cnjg();
  8496.  
  8497.     /* Local variables */
  8498. #define egnd (equiv_8)
  8499.     static doublereal shaf;
  8500.     extern /* Subroutine */ int eksc_();
  8501.     static doublereal rmag, dmin_;
  8502.     static doublecomplex terc, refs, tezc, terk, ters, tezk;
  8503.     static doublereal rhox, rhoy, rhoz;
  8504.     static doublecomplex tezs;
  8505.     static doublereal r;
  8506.     extern /* Subroutine */ int sflds_(), ekscx_();
  8507.     static doublecomplex refps;
  8508.     static doublereal salpr, xspec, yspec, xymag;
  8509.     static doublecomplex zscrn, zrsin, zratx;
  8510.     static integer ip;
  8511.     static doublereal rh, zp, px, py, rhospc, cth, rfl, xij, yij;
  8512.     static doublecomplex epx, epy;
  8513. #define txc (equiv_8 + 6)
  8514. #define tyc (equiv_8 + 7)
  8515. #define tzc (equiv_8 + 8)
  8516.     static integer ijx;
  8517.     static doublereal zij;
  8518. #define txk (equiv_8)
  8519. #define tyk (equiv_8 + 1)
  8520. #define tzk (equiv_8 + 2)
  8521. #define txs (equiv_8 + 3)
  8522. #define tys (equiv_8 + 4)
  8523. #define tzs (equiv_8 + 5)
  8524.     extern /* Subroutine */ int rom2_();
  8525.  
  8526. /* *** */
  8527. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  8528.  
  8529. /*     COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND */
  8530. /*     CONSTANT CURRENTS.  GROUND EFFECT INCLUDED. */
  8531.  
  8532. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  8533. /*<    >*/
  8534. /*<    >*/
  8535. /*<    >*/
  8536. /*<       COMMON  /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR >*/
  8537. /*<       DIMENSION  EGND(9) >*/
  8538. /*<    >*/
  8539. /*<       DATA   ETA/376.73/, PI/3.141592654D+0/, TP/6.283185308D+0/ >*/
  8540. /*<       XIJ= XI- XJ >*/
  8541.     xij = *xi - dataj_1.xj;
  8542. /*<       YIJ= YI- YJ >*/
  8543.     yij = *yi - dataj_1.yj;
  8544. /*<       IJX= IJ >*/
  8545.     ijx = *ij;
  8546. /*<       RFL=-1. >*/
  8547.     rfl = -1.;
  8548. /*<       DO 12  IP=1, KSYMP >*/
  8549.     i__1 = gnd_1.ksymp;
  8550.     for (ip = 1; ip <= i__1; ++ip) {
  8551. /*<       IF( IP.EQ.2) IJX=1 >*/
  8552.     if (ip == 2) {
  8553.         ijx = 1;
  8554.     }
  8555. /*<       RFL=- RFL >*/
  8556.     rfl = -rfl;
  8557. /*<       SALPR= SALPJ* RFL >*/
  8558.     salpr = dataj_1.salpj * rfl;
  8559. /*<       ZIJ= ZI- RFL* ZJ >*/
  8560.     zij = *zi - rfl * dataj_1.zj;
  8561. /*<       ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR >*/
  8562.     d__1 = xij * dataj_1.cabj + yij * dataj_1.sabj;
  8563.     zp = d__1 + zij * salpr;
  8564. /*<       RHOX= XIJ- CABJ* ZP >*/
  8565.     rhox = xij - dataj_1.cabj * zp;
  8566. /*<       RHOY= YIJ- SABJ* ZP >*/
  8567.     rhoy = yij - dataj_1.sabj * zp;
  8568. /*<       RHOZ= ZIJ- SALPR* ZP >*/
  8569.     rhoz = zij - salpr * zp;
  8570. /*<       RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI) >*/
  8571.     d__2 = rhox * rhox + rhoy * rhoy;
  8572.     d__1 = d__2 + rhoz * rhoz;
  8573.     rh = sqrt(d__1 + *ai * *ai);
  8574. /*<       IF( RH.GT.1.D-10) GOTO 1 >*/
  8575.     if (rh > 1e-10) {
  8576.         goto L1;
  8577.     }
  8578. /*<       RHOX=0. >*/
  8579.     rhox = 0.;
  8580. /*<       RHOY=0. >*/
  8581.     rhoy = 0.;
  8582. /*<       RHOZ=0. >*/
  8583.     rhoz = 0.;
  8584. /*<       GOTO 2 >*/
  8585.     goto L2;
  8586. /*<     1 RHOX= RHOX/ RH >*/
  8587. L1:
  8588.     rhox /= rh;
  8589. /*<       RHOY= RHOY/ RH >*/
  8590.     rhoy /= rh;
  8591. /*<       RHOZ= RHOZ/ RH >*/
  8592.     rhoz /= rh;
  8593. /*<     2 R= SQRT( ZP* ZP+ RH* RH) >*/
  8594. L2:
  8595.     r = sqrt(zp * zp + rh * rh);
  8596.  
  8597. /*     LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS */
  8598.  
  8599. /*<       IF( R.LT. RKH) GOTO 3 >*/
  8600.     if (r < dataj_1.rkh) {
  8601.         goto L3;
  8602.     }
  8603. /*<       RMAG= TP* R >*/
  8604.     rmag = tp * r;
  8605. /*<       CTH= ZP/ R >*/
  8606.     cth = zp / r;
  8607. /*<       PX= RH/ R >*/
  8608.     px = rh / r;
  8609. /*<       TXK= CMPLX( COS( RMAG),- SIN( RMAG)) >*/
  8610.     d__1 = cos(rmag);
  8611.     d__2 = -sin(rmag);
  8612.     z__1.r = d__1, z__1.i = d__2;
  8613.     txk->r = z__1.r, txk->i = z__1.i;
  8614. /*<       PY= TP* R* R >*/
  8615.     d__1 = tp * r;
  8616.     py = d__1 * r;
  8617. /*<       TYK= ETA* CTH* TXK* CMPLX(1.D+0,-1.D+0/ RMAG)/ PY >*/
  8618.     d__1 = eta * cth;
  8619.     z__3.r = d__1 * txk->r, z__3.i = d__1 * txk->i;
  8620.     d__2 = -1. / rmag;
  8621.     z__4.r = 1., z__4.i = d__2;
  8622.     z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i 
  8623.         + z__3.i * z__4.r;
  8624.     z__1.r = z__2.r / py, z__1.i = z__2.i / py;
  8625.     tyk->r = z__1.r, tyk->i = z__1.i;
  8626. /*<       TZK= ETA* PX* TXK* CMPLX(1.D+0, RMAG-1.D+0/ RMAG)/(2.* PY) >*/
  8627.     d__1 = eta * px;
  8628.     z__3.r = d__1 * txk->r, z__3.i = d__1 * txk->i;
  8629.     d__2 = rmag - 1. / rmag;
  8630.     z__4.r = 1., z__4.i = d__2;
  8631.     z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i 
  8632.         + z__3.i * z__4.r;
  8633.     d__3 = py * 2.;
  8634.     z__1.r = z__2.r / d__3, z__1.i = z__2.i / d__3;
  8635.     tzk->r = z__1.r, tzk->i = z__1.i;
  8636. /*<       TEZK= TYK* CTH- TZK* PX >*/
  8637.     z__2.r = cth * tyk->r, z__2.i = cth * tyk->i;
  8638.     z__3.r = px * tzk->r, z__3.i = px * tzk->i;
  8639.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  8640.     tezk.r = z__1.r, tezk.i = z__1.i;
  8641. /*<       TERK= TYK* PX+ TZK* CTH >*/
  8642.     z__2.r = px * tyk->r, z__2.i = px * tyk->i;
  8643.     z__3.r = cth * tzk->r, z__3.i = cth * tzk->i;
  8644.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8645.     terk.r = z__1.r, terk.i = z__1.i;
  8646. /*<       RMAG= SIN( PI* S)/ PI >*/
  8647.     rmag = sin(pi * dataj_1.s) / pi;
  8648. /*<       TEZC= TEZK* RMAG >*/
  8649.     z__1.r = rmag * tezk.r, z__1.i = rmag * tezk.i;
  8650.     tezc.r = z__1.r, tezc.i = z__1.i;
  8651. /*<       TERC= TERK* RMAG >*/
  8652.     z__1.r = rmag * terk.r, z__1.i = rmag * terk.i;
  8653.     terc.r = z__1.r, terc.i = z__1.i;
  8654. /*<       TEZK= TEZK* S >*/
  8655.     z__1.r = dataj_1.s * tezk.r, z__1.i = dataj_1.s * tezk.i;
  8656.     tezk.r = z__1.r, tezk.i = z__1.i;
  8657. /*<       TERK= TERK* S >*/
  8658.     z__1.r = dataj_1.s * terk.r, z__1.i = dataj_1.s * terk.i;
  8659.     terk.r = z__1.r, terk.i = z__1.i;
  8660. /*<       TXS=(0.,0.) >*/
  8661.     txs->r = 0., txs->i = 0.;
  8662. /*<       TYS=(0.,0.) >*/
  8663.     tys->r = 0., tys->i = 0.;
  8664. /*<       TZS=(0.,0.) >*/
  8665.     tzs->r = 0., tzs->i = 0.;
  8666. /*<       GOTO 6 >*/
  8667.     goto L6;
  8668.  
  8669. /*     EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX. 
  8670. */
  8671.  
  8672. /*<     3 IF( IEXK.EQ.1) GOTO 4 >*/
  8673. L3:
  8674.     if (dataj_1.iexk == 1) {
  8675.         goto L4;
  8676.     }
  8677. /*<    >*/
  8678.     eksc_(&dataj_1.s, &zp, &rh, &tp, &ijx, &tezs, &ters, &tezc, &terc, &
  8679.         tezk, &terk);
  8680. /*<       GOTO 5 >*/
  8681.     goto L5;
  8682. /*<    >*/
  8683. L4:
  8684.     ekscx_(&dataj_1.b, &dataj_1.s, &zp, &rh, &tp, &ijx, &dataj_1.ind1, &
  8685.         dataj_1.ind2, &tezs, &ters, &tezc, &terc, &tezk, &terk);
  8686. /*<     5 TXS= TEZS* CABJ+ TERS* RHOX >*/
  8687. L5:
  8688.     z__2.r = dataj_1.cabj * tezs.r, z__2.i = dataj_1.cabj * tezs.i;
  8689.     z__3.r = rhox * ters.r, z__3.i = rhox * ters.i;
  8690.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8691.     txs->r = z__1.r, txs->i = z__1.i;
  8692. /*<       TYS= TEZS* SABJ+ TERS* RHOY >*/
  8693.     z__2.r = dataj_1.sabj * tezs.r, z__2.i = dataj_1.sabj * tezs.i;
  8694.     z__3.r = rhoy * ters.r, z__3.i = rhoy * ters.i;
  8695.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8696.     tys->r = z__1.r, tys->i = z__1.i;
  8697. /*<       TZS= TEZS* SALPR+ TERS* RHOZ >*/
  8698.     z__2.r = salpr * tezs.r, z__2.i = salpr * tezs.i;
  8699.     z__3.r = rhoz * ters.r, z__3.i = rhoz * ters.i;
  8700.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8701.     tzs->r = z__1.r, tzs->i = z__1.i;
  8702. /*<     6 TXK= TEZK* CABJ+ TERK* RHOX >*/
  8703. L6:
  8704.     z__2.r = dataj_1.cabj * tezk.r, z__2.i = dataj_1.cabj * tezk.i;
  8705.     z__3.r = rhox * terk.r, z__3.i = rhox * terk.i;
  8706.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8707.     txk->r = z__1.r, txk->i = z__1.i;
  8708. /*<       TYK= TEZK* SABJ+ TERK* RHOY >*/
  8709.     z__2.r = dataj_1.sabj * tezk.r, z__2.i = dataj_1.sabj * tezk.i;
  8710.     z__3.r = rhoy * terk.r, z__3.i = rhoy * terk.i;
  8711.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8712.     tyk->r = z__1.r, tyk->i = z__1.i;
  8713. /*<       TZK= TEZK* SALPR+ TERK* RHOZ >*/
  8714.     z__2.r = salpr * tezk.r, z__2.i = salpr * tezk.i;
  8715.     z__3.r = rhoz * terk.r, z__3.i = rhoz * terk.i;
  8716.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8717.     tzk->r = z__1.r, tzk->i = z__1.i;
  8718. /*<       TXC= TEZC* CABJ+ TERC* RHOX >*/
  8719.     z__2.r = dataj_1.cabj * tezc.r, z__2.i = dataj_1.cabj * tezc.i;
  8720.     z__3.r = rhox * terc.r, z__3.i = rhox * terc.i;
  8721.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8722.     txc->r = z__1.r, txc->i = z__1.i;
  8723. /*<       TYC= TEZC* SABJ+ TERC* RHOY >*/
  8724.     z__2.r = dataj_1.sabj * tezc.r, z__2.i = dataj_1.sabj * tezc.i;
  8725.     z__3.r = rhoy * terc.r, z__3.i = rhoy * terc.i;
  8726.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8727.     tyc->r = z__1.r, tyc->i = z__1.i;
  8728. /*<       TZC= TEZC* SALPR+ TERC* RHOZ >*/
  8729.     z__2.r = salpr * tezc.r, z__2.i = salpr * tezc.i;
  8730.     z__3.r = rhoz * terc.r, z__3.i = rhoz * terc.i;
  8731.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8732.     tzc->r = z__1.r, tzc->i = z__1.i;
  8733. /*<       IF( IP.NE.2) GOTO 11 >*/
  8734.     if (ip != 2) {
  8735.         goto L11;
  8736.     }
  8737. /*<       IF( IPERF.GT.0) GOTO 10 >*/
  8738.     if (gnd_1.iperf > 0) {
  8739.         goto L10;
  8740.     }
  8741. /*<       ZRATX= ZRATI >*/
  8742.     zratx.r = gnd_1.zrati.r, zratx.i = gnd_1.zrati.i;
  8743. /*<       RMAG= R >*/
  8744.     rmag = r;
  8745.  
  8746. /*     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN. */
  8747.  
  8748. /*<       XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ) >*/
  8749.     xymag = sqrt(xij * xij + yij * yij);
  8750. /*<       IF( NRADL.EQ.0) GOTO 7 >*/
  8751.     if (gnd_1.nradl == 0) {
  8752.         goto L7;
  8753.     }
  8754. /*<       XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ) >*/
  8755.     xspec = (*xi * dataj_1.zj + *zi * dataj_1.xj) / (*zi + dataj_1.zj);
  8756. /*<       YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ) >*/
  8757.     yspec = (*yi * dataj_1.zj + *zi * dataj_1.yj) / (*zi + dataj_1.zj);
  8758. /*<       RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2) >*/
  8759.     d__1 = xspec * xspec + yspec * yspec;
  8760.     rhospc = sqrt(d__1 + gnd_1.t2 * gnd_1.t2);
  8761. /*<       IF( RHOSPC.GT. SCRWL) GOTO 7 >*/
  8762.     if (rhospc > gnd_1.scrwl) {
  8763.         goto L7;
  8764.     }
  8765. /*<       ZSCRN= T1* RHOSPC* LOG( RHOSPC/ T2) >*/
  8766.     z__2.r = rhospc * gnd_1.t1.r, z__2.i = rhospc * gnd_1.t1.i;
  8767.     d__1 = log(rhospc / gnd_1.t2);
  8768.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  8769.     zscrn.r = z__1.r, zscrn.i = z__1.i;
  8770. /*<       ZRATX=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN) >*/
  8771.     z__2.r = zscrn.r * gnd_1.zrati.r - zscrn.i * gnd_1.zrati.i, z__2.i = 
  8772.         zscrn.r * gnd_1.zrati.i + zscrn.i * gnd_1.zrati.r;
  8773.     z__4.r = eta * gnd_1.zrati.r, z__4.i = eta * gnd_1.zrati.i;
  8774.     z__3.r = z__4.r + zscrn.r, z__3.i = z__4.i + zscrn.i;
  8775.     z_div(&z__1, &z__2, &z__3);
  8776.     zratx.r = z__1.r, zratx.i = z__1.i;
  8777.  
  8778. /*     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED
  8779. . */
  8780.  
  8781. /*<     7 IF( XYMAG.GT.1.D-6) GOTO 8 >*/
  8782. L7:
  8783.     if (xymag > 1e-6) {
  8784.         goto L8;
  8785.     }
  8786. /*<       PX=0. >*/
  8787.     px = 0.;
  8788. /*<       PY=0. >*/
  8789.     py = 0.;
  8790. /*<       CTH=1. >*/
  8791.     cth = 1.;
  8792. /*<       ZRSIN=(1.,0.) >*/
  8793.     zrsin.r = 1., zrsin.i = 0.;
  8794. /*<       GOTO 9 >*/
  8795.     goto L9;
  8796. /*<     8 PX=- YIJ/ XYMAG >*/
  8797. L8:
  8798.     px = -yij / xymag;
  8799. /*<       PY= XIJ/ XYMAG >*/
  8800.     py = xij / xymag;
  8801. /*<       CTH= ZIJ/ RMAG >*/
  8802.     cth = zij / rmag;
  8803. /*<       ZRSIN= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH)) >*/
  8804.     z__4.r = zratx.r * zratx.r - zratx.i * zratx.i, z__4.i = zratx.r * 
  8805.         zratx.i + zratx.i * zratx.r;
  8806.     d__1 = 1. - cth * cth;
  8807.     z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
  8808.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  8809.     z_sqrt(&z__1, &z__2);
  8810.     zrsin.r = z__1.r, zrsin.i = z__1.i;
  8811. /*<     9 REFS=( CTH- ZRATX* ZRSIN)/( CTH+ ZRATX* ZRSIN) >*/
  8812. L9:
  8813.     z__3.r = zratx.r * zrsin.r - zratx.i * zrsin.i, z__3.i = zratx.r * 
  8814.         zrsin.i + zratx.i * zrsin.r;
  8815.     z__2.r = cth - z__3.r, z__2.i = -z__3.i;
  8816.     z__5.r = zratx.r * zrsin.r - zratx.i * zrsin.i, z__5.i = zratx.r * 
  8817.         zrsin.i + zratx.i * zrsin.r;
  8818.     z__4.r = cth + z__5.r, z__4.i = z__5.i;
  8819.     z_div(&z__1, &z__2, &z__4);
  8820.     refs.r = z__1.r, refs.i = z__1.i;
  8821. /*<       REFPS=-( ZRATX* CTH- ZRSIN)/( ZRATX* CTH+ ZRSIN) >*/
  8822.     z__4.r = cth * zratx.r, z__4.i = cth * zratx.i;
  8823.     z__3.r = z__4.r - zrsin.r, z__3.i = z__4.i - zrsin.i;
  8824.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  8825.     z__6.r = cth * zratx.r, z__6.i = cth * zratx.i;
  8826.     z__5.r = z__6.r + zrsin.r, z__5.i = z__6.i + zrsin.i;
  8827.     z_div(&z__1, &z__2, &z__5);
  8828.     refps.r = z__1.r, refps.i = z__1.i;
  8829. /*<       REFPS= REFPS- REFS >*/
  8830.     z__1.r = refps.r - refs.r, z__1.i = refps.i - refs.i;
  8831.     refps.r = z__1.r, refps.i = z__1.i;
  8832. /*<       EPY= PX* TXK+ PY* TYK >*/
  8833.     z__2.r = px * txk->r, z__2.i = px * txk->i;
  8834.     z__3.r = py * tyk->r, z__3.i = py * tyk->i;
  8835.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8836.     epy.r = z__1.r, epy.i = z__1.i;
  8837. /*<       EPX= PX* EPY >*/
  8838.     z__1.r = px * epy.r, z__1.i = px * epy.i;
  8839.     epx.r = z__1.r, epx.i = z__1.i;
  8840. /*<       EPY= PY* EPY >*/
  8841.     z__1.r = py * epy.r, z__1.i = py * epy.i;
  8842.     epy.r = z__1.r, epy.i = z__1.i;
  8843. /*<       TXK= REFS* TXK+ REFPS* EPX >*/
  8844.     z__2.r = refs.r * txk->r - refs.i * txk->i, z__2.i = refs.r * txk->i 
  8845.         + refs.i * txk->r;
  8846.     z__3.r = refps.r * epx.r - refps.i * epx.i, z__3.i = refps.r * epx.i 
  8847.         + refps.i * epx.r;
  8848.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8849.     txk->r = z__1.r, txk->i = z__1.i;
  8850. /*<       TYK= REFS* TYK+ REFPS* EPY >*/
  8851.     z__2.r = refs.r * tyk->r - refs.i * tyk->i, z__2.i = refs.r * tyk->i 
  8852.         + refs.i * tyk->r;
  8853.     z__3.r = refps.r * epy.r - refps.i * epy.i, z__3.i = refps.r * epy.i 
  8854.         + refps.i * epy.r;
  8855.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8856.     tyk->r = z__1.r, tyk->i = z__1.i;
  8857. /*<       TZK= REFS* TZK >*/
  8858.     z__1.r = refs.r * tzk->r - refs.i * tzk->i, z__1.i = refs.r * tzk->i 
  8859.         + refs.i * tzk->r;
  8860.     tzk->r = z__1.r, tzk->i = z__1.i;
  8861. /*<       EPY= PX* TXS+ PY* TYS >*/
  8862.     z__2.r = px * txs->r, z__2.i = px * txs->i;
  8863.     z__3.r = py * tys->r, z__3.i = py * tys->i;
  8864.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8865.     epy.r = z__1.r, epy.i = z__1.i;
  8866. /*<       EPX= PX* EPY >*/
  8867.     z__1.r = px * epy.r, z__1.i = px * epy.i;
  8868.     epx.r = z__1.r, epx.i = z__1.i;
  8869. /*<       EPY= PY* EPY >*/
  8870.     z__1.r = py * epy.r, z__1.i = py * epy.i;
  8871.     epy.r = z__1.r, epy.i = z__1.i;
  8872. /*<       TXS= REFS* TXS+ REFPS* EPX >*/
  8873.     z__2.r = refs.r * txs->r - refs.i * txs->i, z__2.i = refs.r * txs->i 
  8874.         + refs.i * txs->r;
  8875.     z__3.r = refps.r * epx.r - refps.i * epx.i, z__3.i = refps.r * epx.i 
  8876.         + refps.i * epx.r;
  8877.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8878.     txs->r = z__1.r, txs->i = z__1.i;
  8879. /*<       TYS= REFS* TYS+ REFPS* EPY >*/
  8880.     z__2.r = refs.r * tys->r - refs.i * tys->i, z__2.i = refs.r * tys->i 
  8881.         + refs.i * tys->r;
  8882.     z__3.r = refps.r * epy.r - refps.i * epy.i, z__3.i = refps.r * epy.i 
  8883.         + refps.i * epy.r;
  8884.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8885.     tys->r = z__1.r, tys->i = z__1.i;
  8886. /*<       TZS= REFS* TZS >*/
  8887.     z__1.r = refs.r * tzs->r - refs.i * tzs->i, z__1.i = refs.r * tzs->i 
  8888.         + refs.i * tzs->r;
  8889.     tzs->r = z__1.r, tzs->i = z__1.i;
  8890. /*<       EPY= PX* TXC+ PY* TYC >*/
  8891.     z__2.r = px * txc->r, z__2.i = px * txc->i;
  8892.     z__3.r = py * tyc->r, z__3.i = py * tyc->i;
  8893.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8894.     epy.r = z__1.r, epy.i = z__1.i;
  8895. /*<       EPX= PX* EPY >*/
  8896.     z__1.r = px * epy.r, z__1.i = px * epy.i;
  8897.     epx.r = z__1.r, epx.i = z__1.i;
  8898. /*<       EPY= PY* EPY >*/
  8899.     z__1.r = py * epy.r, z__1.i = py * epy.i;
  8900.     epy.r = z__1.r, epy.i = z__1.i;
  8901. /*<       TXC= REFS* TXC+ REFPS* EPX >*/
  8902.     z__2.r = refs.r * txc->r - refs.i * txc->i, z__2.i = refs.r * txc->i 
  8903.         + refs.i * txc->r;
  8904.     z__3.r = refps.r * epx.r - refps.i * epx.i, z__3.i = refps.r * epx.i 
  8905.         + refps.i * epx.r;
  8906.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8907.     txc->r = z__1.r, txc->i = z__1.i;
  8908. /*<       TYC= REFS* TYC+ REFPS* EPY >*/
  8909.     z__2.r = refs.r * tyc->r - refs.i * tyc->i, z__2.i = refs.r * tyc->i 
  8910.         + refs.i * tyc->r;
  8911.     z__3.r = refps.r * epy.r - refps.i * epy.i, z__3.i = refps.r * epy.i 
  8912.         + refps.i * epy.r;
  8913.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  8914.     tyc->r = z__1.r, tyc->i = z__1.i;
  8915. /*<       TZC= REFS* TZC >*/
  8916.     z__1.r = refs.r * tzc->r - refs.i * tzc->i, z__1.i = refs.r * tzc->i 
  8917.         + refs.i * tzc->r;
  8918.     tzc->r = z__1.r, tzc->i = z__1.i;
  8919. /*<    10 EXK= EXK- TXK* FRATI >*/
  8920. L10:
  8921.     z__2.r = txk->r * gnd_1.frati.r - txk->i * gnd_1.frati.i, z__2.i = 
  8922.         txk->r * gnd_1.frati.i + txk->i * gnd_1.frati.r;
  8923.     z__1.r = dataj_1.exk.r - z__2.r, z__1.i = dataj_1.exk.i - z__2.i;
  8924.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  8925. /*<       EYK= EYK- TYK* FRATI >*/
  8926.     z__2.r = tyk->r * gnd_1.frati.r - tyk->i * gnd_1.frati.i, z__2.i = 
  8927.         tyk->r * gnd_1.frati.i + tyk->i * gnd_1.frati.r;
  8928.     z__1.r = dataj_1.eyk.r - z__2.r, z__1.i = dataj_1.eyk.i - z__2.i;
  8929.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  8930. /*<       EZK= EZK- TZK* FRATI >*/
  8931.     z__2.r = tzk->r * gnd_1.frati.r - tzk->i * gnd_1.frati.i, z__2.i = 
  8932.         tzk->r * gnd_1.frati.i + tzk->i * gnd_1.frati.r;
  8933.     z__1.r = dataj_1.ezk.r - z__2.r, z__1.i = dataj_1.ezk.i - z__2.i;
  8934.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  8935. /*<       EXS= EXS- TXS* FRATI >*/
  8936.     z__2.r = txs->r * gnd_1.frati.r - txs->i * gnd_1.frati.i, z__2.i = 
  8937.         txs->r * gnd_1.frati.i + txs->i * gnd_1.frati.r;
  8938.     z__1.r = dataj_1.exs.r - z__2.r, z__1.i = dataj_1.exs.i - z__2.i;
  8939.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  8940. /*<       EYS= EYS- TYS* FRATI >*/
  8941.     z__2.r = tys->r * gnd_1.frati.r - tys->i * gnd_1.frati.i, z__2.i = 
  8942.         tys->r * gnd_1.frati.i + tys->i * gnd_1.frati.r;
  8943.     z__1.r = dataj_1.eys.r - z__2.r, z__1.i = dataj_1.eys.i - z__2.i;
  8944.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  8945. /*<       EZS= EZS- TZS* FRATI >*/
  8946.     z__2.r = tzs->r * gnd_1.frati.r - tzs->i * gnd_1.frati.i, z__2.i = 
  8947.         tzs->r * gnd_1.frati.i + tzs->i * gnd_1.frati.r;
  8948.     z__1.r = dataj_1.ezs.r - z__2.r, z__1.i = dataj_1.ezs.i - z__2.i;
  8949.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  8950. /*<       EXC= EXC- TXC* FRATI >*/
  8951.     z__2.r = txc->r * gnd_1.frati.r - txc->i * gnd_1.frati.i, z__2.i = 
  8952.         txc->r * gnd_1.frati.i + txc->i * gnd_1.frati.r;
  8953.     z__1.r = dataj_1.exc.r - z__2.r, z__1.i = dataj_1.exc.i - z__2.i;
  8954.     dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  8955. /*<       EYC= EYC- TYC* FRATI >*/
  8956.     z__2.r = tyc->r * gnd_1.frati.r - tyc->i * gnd_1.frati.i, z__2.i = 
  8957.         tyc->r * gnd_1.frati.i + tyc->i * gnd_1.frati.r;
  8958.     z__1.r = dataj_1.eyc.r - z__2.r, z__1.i = dataj_1.eyc.i - z__2.i;
  8959.     dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
  8960. /*<       EZC= EZC- TZC* FRATI >*/
  8961.     z__2.r = tzc->r * gnd_1.frati.r - tzc->i * gnd_1.frati.i, z__2.i = 
  8962.         tzc->r * gnd_1.frati.i + tzc->i * gnd_1.frati.r;
  8963.     z__1.r = dataj_1.ezc.r - z__2.r, z__1.i = dataj_1.ezc.i - z__2.i;
  8964.     dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
  8965. /*<       GOTO 12 >*/
  8966.     goto L12;
  8967. /*<    11 EXK= TXK >*/
  8968. L11:
  8969.     dataj_1.exk.r = txk->r, dataj_1.exk.i = txk->i;
  8970. /*<       EYK= TYK >*/
  8971.     dataj_1.eyk.r = tyk->r, dataj_1.eyk.i = tyk->i;
  8972. /*<       EZK= TZK >*/
  8973.     dataj_1.ezk.r = tzk->r, dataj_1.ezk.i = tzk->i;
  8974. /*<       EXS= TXS >*/
  8975.     dataj_1.exs.r = txs->r, dataj_1.exs.i = txs->i;
  8976. /*<       EYS= TYS >*/
  8977.     dataj_1.eys.r = tys->r, dataj_1.eys.i = tys->i;
  8978. /*<       EZS= TZS >*/
  8979.     dataj_1.ezs.r = tzs->r, dataj_1.ezs.i = tzs->i;
  8980. /*<       EXC= TXC >*/
  8981.     dataj_1.exc.r = txc->r, dataj_1.exc.i = txc->i;
  8982. /*<       EYC= TYC >*/
  8983.     dataj_1.eyc.r = tyc->r, dataj_1.eyc.i = tyc->i;
  8984. /*<       EZC= TZC >*/
  8985.     dataj_1.ezc.r = tzc->r, dataj_1.ezc.i = tzc->i;
  8986. /*<    12 CONTINUE >*/
  8987. L12:
  8988.     ;
  8989.     }
  8990. /*<       IF( IPERF.EQ.2) GOTO 13 >*/
  8991.     if (gnd_1.iperf == 2) {
  8992.     goto L13;
  8993.     }
  8994.  
  8995. /*     FIELD DUE TO GROUND USING SOMMERFELD/NORTON */
  8996.  
  8997. /*<       RETURN >*/
  8998.     return 0;
  8999. /*<    13 SN= SQRT( CABJ* CABJ+ SABJ* SABJ) >*/
  9000. L13:
  9001.     incom_1.sn = sqrt(dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * 
  9002.         dataj_1.sabj);
  9003. /*<       IF( SN.LT.1.D-5) GOTO 14 >*/
  9004.     if (incom_1.sn < 1e-5) {
  9005.     goto L14;
  9006.     }
  9007. /*<       XSN= CABJ/ SN >*/
  9008.     incom_1.xsn = dataj_1.cabj / incom_1.sn;
  9009. /*<       YSN= SABJ/ SN >*/
  9010.     incom_1.ysn = dataj_1.sabj / incom_1.sn;
  9011. /*<       GOTO 15 >*/
  9012.     goto L15;
  9013. /*<    14 SN=0. >*/
  9014. L14:
  9015.     incom_1.sn = 0.;
  9016. /*<       XSN=1. >*/
  9017.     incom_1.xsn = 1.;
  9018.  
  9019. /*     DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION */
  9020.  
  9021. /*<       YSN=0. >*/
  9022.     incom_1.ysn = 0.;
  9023. /*<    15 ZIJ= ZI+ ZJ >*/
  9024. L15:
  9025.     zij = *zi + dataj_1.zj;
  9026. /*<       SALPR=- SALPJ >*/
  9027.     salpr = -dataj_1.salpj;
  9028. /*<       RHOX= SABJ* ZIJ- SALPR* YIJ >*/
  9029.     rhox = dataj_1.sabj * zij - salpr * yij;
  9030. /*<       RHOY= SALPR* XIJ- CABJ* ZIJ >*/
  9031.     rhoy = salpr * xij - dataj_1.cabj * zij;
  9032. /*<       RHOZ= CABJ* YIJ- SABJ* XIJ >*/
  9033.     rhoz = dataj_1.cabj * yij - dataj_1.sabj * xij;
  9034. /*<       RH= RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ >*/
  9035.     d__1 = rhox * rhox + rhoy * rhoy;
  9036.     rh = d__1 + rhoz * rhoz;
  9037. /*<       IF( RH.GT.1.D-10) GOTO 16 >*/
  9038.     if (rh > 1e-10) {
  9039.     goto L16;
  9040.     }
  9041. /*<       XO= XI- AI* YSN >*/
  9042.     incom_1.xo = *xi - *ai * incom_1.ysn;
  9043. /*<       YO= YI+ AI* XSN >*/
  9044.     incom_1.yo = *yi + *ai * incom_1.xsn;
  9045. /*<       ZO= ZI >*/
  9046.     incom_1.zo = *zi;
  9047. /*<       GOTO 17 >*/
  9048.     goto L17;
  9049. /*<    16 RH= AI/ SQRT( RH) >*/
  9050. L16:
  9051.     rh = *ai / sqrt(rh);
  9052. /*<       IF( RHOZ.LT.0.) RH=- RH >*/
  9053.     if (rhoz < 0.) {
  9054.     rh = -rh;
  9055.     }
  9056. /*<       XO= XI+ RH* RHOX >*/
  9057.     incom_1.xo = *xi + rh * rhox;
  9058. /*<       YO= YI+ RH* RHOY >*/
  9059.     incom_1.yo = *yi + rh * rhoy;
  9060. /*<       ZO= ZI+ RH* RHOZ >*/
  9061.     incom_1.zo = *zi + rh * rhoz;
  9062. /*<    17 R= XIJ* XIJ+ YIJ* YIJ+ ZIJ* ZIJ >*/
  9063. L17:
  9064.     d__1 = xij * xij + yij * yij;
  9065.     r = d__1 + zij * zij;
  9066.  
  9067. /*     FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT */
  9068.  
  9069. /*<       IF( R.GT..95) GOTO 18 >*/
  9070.     if (r > .95) {
  9071.     goto L18;
  9072.     }
  9073. /*<       ISNOR=1 >*/
  9074.     incom_1.isnor = 1;
  9075. /*<       DMIN= EXK* CONJG( EXK)+ EYK* CONJG( EYK)+ EZK* CONJG( EZK) >*/
  9076.     d_cnjg(&z__4, &dataj_1.exk);
  9077.     z__3.r = dataj_1.exk.r * z__4.r - dataj_1.exk.i * z__4.i, z__3.i = 
  9078.         dataj_1.exk.r * z__4.i + dataj_1.exk.i * z__4.r;
  9079.     d_cnjg(&z__6, &dataj_1.eyk);
  9080.     z__5.r = dataj_1.eyk.r * z__6.r - dataj_1.eyk.i * z__6.i, z__5.i = 
  9081.         dataj_1.eyk.r * z__6.i + dataj_1.eyk.i * z__6.r;
  9082.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  9083.     d_cnjg(&z__8, &dataj_1.ezk);
  9084.     z__7.r = dataj_1.ezk.r * z__8.r - dataj_1.ezk.i * z__8.i, z__7.i = 
  9085.         dataj_1.ezk.r * z__8.i + dataj_1.ezk.i * z__8.r;
  9086.     z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
  9087.     dmin_ = z__1.r;
  9088. /*<       DMIN=.01* SQRT( DMIN) >*/
  9089.     dmin_ = sqrt(dmin_) * .01;
  9090. /*<       SHAF=.5* S >*/
  9091.     shaf = dataj_1.s * .5;
  9092. /*<       CALL ROM2(- SHAF, SHAF, EGND, DMIN) >*/
  9093.     d__1 = -shaf;
  9094.     rom2_(&d__1, &shaf, egnd, &dmin_);
  9095.  
  9096. /*     NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION */
  9097.  
  9098. /*<       GOTO 19 >*/
  9099.     goto L19;
  9100. /*<    18 ISNOR=2 >*/
  9101. L18:
  9102.     incom_1.isnor = 2;
  9103. /*<       CALL SFLDS(0., EGND) >*/
  9104.     sflds_(&c_b594, egnd);
  9105. /*<       GOTO 22 >*/
  9106.     goto L22;
  9107. /*<    19 ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR >*/
  9108. L19:
  9109.     d__1 = xij * dataj_1.cabj + yij * dataj_1.sabj;
  9110.     zp = d__1 + zij * salpr;
  9111. /*<       RH= R- ZP* ZP >*/
  9112.     rh = r - zp * zp;
  9113. /*<       IF( RH.GT.1.D-10) GOTO 20 >*/
  9114.     if (rh > 1e-10) {
  9115.     goto L20;
  9116.     }
  9117. /*<       DMIN=0. >*/
  9118.     dmin_ = 0.;
  9119. /*<       GOTO 21 >*/
  9120.     goto L21;
  9121. /*<    20 DMIN= SQRT( RH/( RH+ AI* AI)) >*/
  9122. L20:
  9123.     dmin_ = sqrt(rh / (rh + *ai * *ai));
  9124. /*<    21 IF( DMIN.GT..95) GOTO 22 >*/
  9125. L21:
  9126.     if (dmin_ > .95) {
  9127.     goto L22;
  9128.     }
  9129. /*<       PX=1.- DMIN >*/
  9130.     px = 1. - dmin_;
  9131. /*<       TERK=( TXK* CABJ+ TYK* SABJ+ TZK* SALPR)* PX >*/
  9132.     z__4.r = dataj_1.cabj * txk->r, z__4.i = dataj_1.cabj * txk->i;
  9133.     z__5.r = dataj_1.sabj * tyk->r, z__5.i = dataj_1.sabj * tyk->i;
  9134.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  9135.     z__6.r = salpr * tzk->r, z__6.i = salpr * tzk->i;
  9136.     z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  9137.     z__1.r = px * z__2.r, z__1.i = px * z__2.i;
  9138.     terk.r = z__1.r, terk.i = z__1.i;
  9139. /*<       TXK= DMIN* TXK+ TERK* CABJ >*/
  9140.     z__2.r = dmin_ * txk->r, z__2.i = dmin_ * txk->i;
  9141.     z__3.r = dataj_1.cabj * terk.r, z__3.i = dataj_1.cabj * terk.i;
  9142.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9143.     txk->r = z__1.r, txk->i = z__1.i;
  9144. /*<       TYK= DMIN* TYK+ TERK* SABJ >*/
  9145.     z__2.r = dmin_ * tyk->r, z__2.i = dmin_ * tyk->i;
  9146.     z__3.r = dataj_1.sabj * terk.r, z__3.i = dataj_1.sabj * terk.i;
  9147.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9148.     tyk->r = z__1.r, tyk->i = z__1.i;
  9149. /*<       TZK= DMIN* TZK+ TERK* SALPR >*/
  9150.     z__2.r = dmin_ * tzk->r, z__2.i = dmin_ * tzk->i;
  9151.     z__3.r = salpr * terk.r, z__3.i = salpr * terk.i;
  9152.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9153.     tzk->r = z__1.r, tzk->i = z__1.i;
  9154. /*<       TERS=( TXS* CABJ+ TYS* SABJ+ TZS* SALPR)* PX >*/
  9155.     z__4.r = dataj_1.cabj * txs->r, z__4.i = dataj_1.cabj * txs->i;
  9156.     z__5.r = dataj_1.sabj * tys->r, z__5.i = dataj_1.sabj * tys->i;
  9157.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  9158.     z__6.r = salpr * tzs->r, z__6.i = salpr * tzs->i;
  9159.     z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  9160.     z__1.r = px * z__2.r, z__1.i = px * z__2.i;
  9161.     ters.r = z__1.r, ters.i = z__1.i;
  9162. /*<       TXS= DMIN* TXS+ TERS* CABJ >*/
  9163.     z__2.r = dmin_ * txs->r, z__2.i = dmin_ * txs->i;
  9164.     z__3.r = dataj_1.cabj * ters.r, z__3.i = dataj_1.cabj * ters.i;
  9165.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9166.     txs->r = z__1.r, txs->i = z__1.i;
  9167. /*<       TYS= DMIN* TYS+ TERS* SABJ >*/
  9168.     z__2.r = dmin_ * tys->r, z__2.i = dmin_ * tys->i;
  9169.     z__3.r = dataj_1.sabj * ters.r, z__3.i = dataj_1.sabj * ters.i;
  9170.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9171.     tys->r = z__1.r, tys->i = z__1.i;
  9172. /*<       TZS= DMIN* TZS+ TERS* SALPR >*/
  9173.     z__2.r = dmin_ * tzs->r, z__2.i = dmin_ * tzs->i;
  9174.     z__3.r = salpr * ters.r, z__3.i = salpr * ters.i;
  9175.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9176.     tzs->r = z__1.r, tzs->i = z__1.i;
  9177. /*<       TERC=( TXC* CABJ+ TYC* SABJ+ TZC* SALPR)* PX >*/
  9178.     z__4.r = dataj_1.cabj * txc->r, z__4.i = dataj_1.cabj * txc->i;
  9179.     z__5.r = dataj_1.sabj * tyc->r, z__5.i = dataj_1.sabj * tyc->i;
  9180.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  9181.     z__6.r = salpr * tzc->r, z__6.i = salpr * tzc->i;
  9182.     z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  9183.     z__1.r = px * z__2.r, z__1.i = px * z__2.i;
  9184.     terc.r = z__1.r, terc.i = z__1.i;
  9185. /*<       TXC= DMIN* TXC+ TERC* CABJ >*/
  9186.     z__2.r = dmin_ * txc->r, z__2.i = dmin_ * txc->i;
  9187.     z__3.r = dataj_1.cabj * terc.r, z__3.i = dataj_1.cabj * terc.i;
  9188.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9189.     txc->r = z__1.r, txc->i = z__1.i;
  9190. /*<       TYC= DMIN* TYC+ TERC* SABJ >*/
  9191.     z__2.r = dmin_ * tyc->r, z__2.i = dmin_ * tyc->i;
  9192.     z__3.r = dataj_1.sabj * terc.r, z__3.i = dataj_1.sabj * terc.i;
  9193.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9194.     tyc->r = z__1.r, tyc->i = z__1.i;
  9195. /*<       TZC= DMIN* TZC+ TERC* SALPR >*/
  9196.     z__2.r = dmin_ * tzc->r, z__2.i = dmin_ * tzc->i;
  9197.     z__3.r = salpr * terc.r, z__3.i = salpr * terc.i;
  9198.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9199.     tzc->r = z__1.r, tzc->i = z__1.i;
  9200. /*<    22 EXK= EXK+ TXK >*/
  9201. L22:
  9202.     z__1.r = dataj_1.exk.r + txk->r, z__1.i = dataj_1.exk.i + txk->i;
  9203.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  9204. /*<       EYK= EYK+ TYK >*/
  9205.     z__1.r = dataj_1.eyk.r + tyk->r, z__1.i = dataj_1.eyk.i + tyk->i;
  9206.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  9207. /*<       EZK= EZK+ TZK >*/
  9208.     z__1.r = dataj_1.ezk.r + tzk->r, z__1.i = dataj_1.ezk.i + tzk->i;
  9209.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  9210. /*<       EXS= EXS+ TXS >*/
  9211.     z__1.r = dataj_1.exs.r + txs->r, z__1.i = dataj_1.exs.i + txs->i;
  9212.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  9213. /*<       EYS= EYS+ TYS >*/
  9214.     z__1.r = dataj_1.eys.r + tys->r, z__1.i = dataj_1.eys.i + tys->i;
  9215.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  9216. /*<       EZS= EZS+ TZS >*/
  9217.     z__1.r = dataj_1.ezs.r + tzs->r, z__1.i = dataj_1.ezs.i + tzs->i;
  9218.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  9219. /*<       EXC= EXC+ TXC >*/
  9220.     z__1.r = dataj_1.exc.r + txc->r, z__1.i = dataj_1.exc.i + txc->i;
  9221.     dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  9222. /*<       EYC= EYC+ TYC >*/
  9223.     z__1.r = dataj_1.eyc.r + tyc->r, z__1.i = dataj_1.eyc.i + tyc->i;
  9224.     dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
  9225. /*<       EZC= EZC+ TZC >*/
  9226.     z__1.r = dataj_1.ezc.r + tzc->r, z__1.i = dataj_1.ezc.i + tzc->i;
  9227.     dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
  9228. /*<       RETURN >*/
  9229.     return 0;
  9230. /*<       END >*/
  9231. } /* efld_ */
  9232.  
  9233. #undef tzs
  9234. #undef tys
  9235. #undef txs
  9236. #undef tzk
  9237. #undef tyk
  9238. #undef txk
  9239. #undef tzc
  9240. #undef tyc
  9241. #undef txc
  9242. #undef egnd
  9243.  
  9244.  
  9245. /* *** */
  9246. /*     DOUBLE PRECISION 6/4/85 */
  9247.  
  9248. /*<       SUBROUTINE EKSC( S, Z, RH, XK, IJ, EZS, ERS, EZC, ERC, EZK, ERK) >*/
  9249. /* Subroutine */ int eksc_(s, z, rh, xk, ij, ezs, ers, ezc, erc, ezk, erk)
  9250. doublereal *s, *z, *rh, *xk;
  9251. integer *ij;
  9252. doublecomplex *ezs, *ers, *ezc, *erc, *ezk, *erk;
  9253. {
  9254.     /* Initialized data */
  9255.  
  9256.     static struct {
  9257.     doublereal e_1[3];
  9258.     } equiv_0 = { 0., 4.771341189, 0. };
  9259.  
  9260.  
  9261.     /* System generated locals */
  9262.     doublereal d__1, d__2;
  9263.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
  9264.          z__11, z__12, z__13;
  9265.  
  9266.     /* Builtin functions */
  9267.     double sin(), cos();
  9268.  
  9269.     /* Local variables */
  9270.     static doublereal cint;
  9271. #define conx ((doublereal *)&equiv_0)
  9272.     static doublereal sint;
  9273.     extern /* Subroutine */ int intx_();
  9274.     static doublereal z1, z2, cs, sh;
  9275.     extern /* Subroutine */ int gx_();
  9276.     static doublereal ss;
  9277.     static doublecomplex gp1, gp2, gz1, gz2;
  9278. #define con ((doublecomplex *)&equiv_0)
  9279.     static doublereal rhk, shk;
  9280.     static doublecomplex gzp1, gzp2;
  9281.  
  9282. /* *** */
  9283. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  9284. /*     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY 
  9285. */
  9286. /*     THIN WIRE APPROXIMATION. */
  9287. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  9288. /*<    >*/
  9289. /*<       COMMON  /TMI/ ZPK, RKB2, IJX >*/
  9290. /*<       DIMENSION  CONX(2) >*/
  9291. /*<       EQUIVALENCE(CONX,CON) >*/
  9292. /*<       DATA   CONX/0.,4.771341189D+0/ >*/
  9293. /*<       IJX= IJ >*/
  9294.     tmi_1.ijx = *ij;
  9295. /*<       ZPK= XK* Z >*/
  9296.     tmi_1.zpk = *xk * *z;
  9297. /*<       RHK= XK* RH >*/
  9298.     rhk = *xk * *rh;
  9299. /*<       RKB2= RHK* RHK >*/
  9300.     tmi_1.rkb2 = rhk * rhk;
  9301. /*<       SH=.5* S >*/
  9302.     sh = *s * .5;
  9303. /*<       SHK= XK* SH >*/
  9304.     shk = *xk * sh;
  9305. /*<       SS= SIN( SHK) >*/
  9306.     ss = sin(shk);
  9307. /*<       CS= COS( SHK) >*/
  9308.     cs = cos(shk);
  9309. /*<       Z2= SH- Z >*/
  9310.     z2 = sh - *z;
  9311. /*<       Z1=-( SH+ Z) >*/
  9312.     z1 = -(sh + *z);
  9313. /*<       CALL GX( Z1, RH, XK, GZ1, GP1) >*/
  9314.     gx_(&z1, rh, xk, &gz1, &gp1);
  9315. /*<       CALL GX( Z2, RH, XK, GZ2, GP2) >*/
  9316.     gx_(&z2, rh, xk, &gz2, &gp2);
  9317. /*<       GZP1= GP1* Z1 >*/
  9318.     z__1.r = z1 * gp1.r, z__1.i = z1 * gp1.i;
  9319.     gzp1.r = z__1.r, gzp1.i = z__1.i;
  9320. /*<       GZP2= GP2* Z2 >*/
  9321.     z__1.r = z2 * gp2.r, z__1.i = z2 * gp2.i;
  9322.     gzp2.r = z__1.r, gzp2.i = z__1.i;
  9323. /*<       EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS) >*/
  9324.     z__5.r = gz2.r - gz1.r, z__5.i = gz2.i - gz1.i;
  9325.     z__4.r = cs * z__5.r, z__4.i = cs * z__5.i;
  9326.     z__3.r = *xk * z__4.r, z__3.i = *xk * z__4.i;
  9327.     z__7.r = gzp2.r + gzp1.r, z__7.i = gzp2.i + gzp1.i;
  9328.     z__6.r = ss * z__7.r, z__6.i = ss * z__7.i;
  9329.     z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
  9330.     z__1.r = con->r * z__2.r - con->i * z__2.i, z__1.i = con->r * z__2.i + 
  9331.         con->i * z__2.r;
  9332.     ezs->r = z__1.r, ezs->i = z__1.i;
  9333. /*<       EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS) >*/
  9334.     z__2.r = -con->r, z__2.i = -con->i;
  9335.     z__6.r = gz2.r + gz1.r, z__6.i = gz2.i + gz1.i;
  9336.     z__5.r = ss * z__6.r, z__5.i = ss * z__6.i;
  9337.     z__4.r = *xk * z__5.r, z__4.i = *xk * z__5.i;
  9338.     z__8.r = gzp2.r - gzp1.r, z__8.i = gzp2.i - gzp1.i;
  9339.     z__7.r = cs * z__8.r, z__7.i = cs * z__8.i;
  9340.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  9341.     z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + 
  9342.         z__2.i * z__3.r;
  9343.     ezc->r = z__1.r, ezc->i = z__1.i;
  9344. /*<       ERK= CON*( GP2- GP1)* RH >*/
  9345.     z__3.r = gp2.r - gp1.r, z__3.i = gp2.i - gp1.i;
  9346.     z__2.r = con->r * z__3.r - con->i * z__3.i, z__2.i = con->r * z__3.i + 
  9347.         con->i * z__3.r;
  9348.     z__1.r = *rh * z__2.r, z__1.i = *rh * z__2.i;
  9349.     erk->r = z__1.r, erk->i = z__1.i;
  9350. /*<       CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT) >*/
  9351.     d__1 = -shk;
  9352.     intx_(&d__1, &shk, &rhk, ij, &cint, &sint);
  9353. /*<       EZK=- CON*( GZP2- GZP1+ XK* XK* CMPLX( CINT,- SINT)) >*/
  9354.     z__2.r = -con->r, z__2.i = -con->i;
  9355.     z__4.r = gzp2.r - gzp1.r, z__4.i = gzp2.i - gzp1.i;
  9356.     d__1 = *xk * *xk;
  9357.     d__2 = -sint;
  9358.     z__6.r = cint, z__6.i = d__2;
  9359.     z__5.r = d__1 * z__6.r, z__5.i = d__1 * z__6.i;
  9360.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  9361.     z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + 
  9362.         z__2.i * z__3.r;
  9363.     ezk->r = z__1.r, ezk->i = z__1.i;
  9364. /*<       GZP1= GZP1* Z1 >*/
  9365.     z__1.r = z1 * gzp1.r, z__1.i = z1 * gzp1.i;
  9366.     gzp1.r = z__1.r, gzp1.i = z__1.i;
  9367. /*<       GZP2= GZP2* Z2 >*/
  9368.     z__1.r = z2 * gzp2.r, z__1.i = z2 * gzp2.i;
  9369.     gzp2.r = z__1.r, gzp2.i = z__1.i;
  9370. /*<       IF( RH.LT.1.D-10) GOTO 1 >*/
  9371.     if (*rh < 1e-10) {
  9372.     goto L1;
  9373.     }
  9374. /*<    >*/
  9375.     z__3.r = -con->r, z__3.i = -con->i;
  9376.     z__8.r = gzp2.r + gzp1.r, z__8.i = gzp2.i + gzp1.i;
  9377.     z__7.r = z__8.r + gz2.r, z__7.i = z__8.i + gz2.i;
  9378.     z__6.r = z__7.r + gz1.r, z__6.i = z__7.i + gz1.i;
  9379.     z__5.r = ss * z__6.r, z__5.i = ss * z__6.i;
  9380.     z__12.r = z2 * gz2.r, z__12.i = z2 * gz2.i;
  9381.     z__13.r = z1 * gz1.r, z__13.i = z1 * gz1.i;
  9382.     z__11.r = z__12.r - z__13.r, z__11.i = z__12.i - z__13.i;
  9383.     z__10.r = cs * z__11.r, z__10.i = cs * z__11.i;
  9384.     z__9.r = *xk * z__10.r, z__9.i = *xk * z__10.i;
  9385.     z__4.r = z__5.r - z__9.r, z__4.i = z__5.i - z__9.i;
  9386.     z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i + 
  9387.         z__3.i * z__4.r;
  9388.     z__1.r = z__2.r / *rh, z__1.i = z__2.i / *rh;
  9389.     ers->r = z__1.r, ers->i = z__1.i;
  9390. /*<    >*/
  9391.     z__3.r = -con->r, z__3.i = -con->i;
  9392.     z__8.r = gzp2.r - gzp1.r, z__8.i = gzp2.i - gzp1.i;
  9393.     z__7.r = z__8.r + gz2.r, z__7.i = z__8.i + gz2.i;
  9394.     z__6.r = z__7.r - gz1.r, z__6.i = z__7.i - gz1.i;
  9395.     z__5.r = cs * z__6.r, z__5.i = cs * z__6.i;
  9396.     z__12.r = z2 * gz2.r, z__12.i = z2 * gz2.i;
  9397.     z__13.r = z1 * gz1.r, z__13.i = z1 * gz1.i;
  9398.     z__11.r = z__12.r + z__13.r, z__11.i = z__12.i + z__13.i;
  9399.     z__10.r = ss * z__11.r, z__10.i = ss * z__11.i;
  9400.     z__9.r = *xk * z__10.r, z__9.i = *xk * z__10.i;
  9401.     z__4.r = z__5.r + z__9.r, z__4.i = z__5.i + z__9.i;
  9402.     z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i + 
  9403.         z__3.i * z__4.r;
  9404.     z__1.r = z__2.r / *rh, z__1.i = z__2.i / *rh;
  9405.     erc->r = z__1.r, erc->i = z__1.i;
  9406. /*<       RETURN >*/
  9407.     return 0;
  9408. /*<     1 ERS=(0.,0.) >*/
  9409. L1:
  9410.     ers->r = 0., ers->i = 0.;
  9411. /*<       ERC=(0.,0.) >*/
  9412.     erc->r = 0., erc->i = 0.;
  9413. /*<       RETURN >*/
  9414.     return 0;
  9415. /*<       END >*/
  9416. } /* eksc_ */
  9417.  
  9418. #undef con
  9419. #undef conx
  9420.  
  9421.  
  9422. /* *** */
  9423. /*     DOUBLE PRECISION 6/4/85 */
  9424.  
  9425. /*<    >*/
  9426. /* Subroutine */ int ekscx_(bx, s, z, rhx, xk, ij, inx1, inx2, ezs, ers, ezc, 
  9427.     erc, ezk, erk)
  9428. doublereal *bx, *s, *z, *rhx, *xk;
  9429. integer *ij, *inx1, *inx2;
  9430. doublecomplex *ezs, *ers, *ezc, *erc, *ezk, *erk;
  9431. {
  9432.     /* Initialized data */
  9433.  
  9434.     static struct {
  9435.     doublereal e_1[3];
  9436.     } equiv_0 = { 0., 4.771341189, 0. };
  9437.  
  9438.  
  9439.     /* System generated locals */
  9440.     doublereal d__1, d__2, d__3;
  9441.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
  9442.          z__11, z__12, z__13, z__14;
  9443.  
  9444.     /* Builtin functions */
  9445.     double sin(), cos();
  9446.  
  9447.     /* Local variables */
  9448.     static doublereal cint;
  9449. #define conx ((doublereal *)&equiv_0)
  9450.     static doublereal sint;
  9451.     extern /* Subroutine */ int intx_();
  9452.     static doublereal b, a2, z1, z2, bk, cs, rh, sh;
  9453.     extern /* Subroutine */ int gx_();
  9454.     static doublereal ss, bk2;
  9455.     static doublecomplex gr1, gr2, gz1, gz2;
  9456.     static integer ira;
  9457. #define con ((doublecomplex *)&equiv_0)
  9458.     static doublereal rhk, shk;
  9459.     extern /* Subroutine */ int gxx_();
  9460.     static doublecomplex grk1, grk2, grp1, grp2, gzp1, gzp2, gzz1, gzz2;
  9461.  
  9462. /* *** */
  9463. /*     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY 
  9464. */
  9465. /*     EXTENDED THIN WIRE APPROXIMATION. */
  9466. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  9467. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  9468. /*<    >*/
  9469. /*<       COMMON  /TMI/ ZPK, RKB2, IJX >*/
  9470. /*<       DIMENSION  CONX(2) >*/
  9471. /*<       EQUIVALENCE(CONX,CON) >*/
  9472. /*<       DATA   CONX/0.,4.771341189D+0/ >*/
  9473. /*<       IF( RHX.LT. BX) GOTO 1 >*/
  9474.     if (*rhx < *bx) {
  9475.     goto L1;
  9476.     }
  9477. /*<       RH= RHX >*/
  9478.     rh = *rhx;
  9479. /*<       B= BX >*/
  9480.     b = *bx;
  9481. /*<       IRA=0 >*/
  9482.     ira = 0;
  9483. /*<       GOTO 2 >*/
  9484.     goto L2;
  9485. /*<     1 RH= BX >*/
  9486. L1:
  9487.     rh = *bx;
  9488. /*<       B= RHX >*/
  9489.     b = *rhx;
  9490. /*<       IRA=1 >*/
  9491.     ira = 1;
  9492. /*<     2 SH=.5* S >*/
  9493. L2:
  9494.     sh = *s * .5;
  9495. /*<       IJX= IJ >*/
  9496.     tmi_1.ijx = *ij;
  9497. /*<       ZPK= XK* Z >*/
  9498.     tmi_1.zpk = *xk * *z;
  9499. /*<       RHK= XK* RH >*/
  9500.     rhk = *xk * rh;
  9501. /*<       RKB2= RHK* RHK >*/
  9502.     tmi_1.rkb2 = rhk * rhk;
  9503. /*<       SHK= XK* SH >*/
  9504.     shk = *xk * sh;
  9505. /*<       SS= SIN( SHK) >*/
  9506.     ss = sin(shk);
  9507. /*<       CS= COS( SHK) >*/
  9508.     cs = cos(shk);
  9509. /*<       Z2= SH- Z >*/
  9510.     z2 = sh - *z;
  9511. /*<       Z1=-( SH+ Z) >*/
  9512.     z1 = -(sh + *z);
  9513. /*<       A2= B* B >*/
  9514.     a2 = b * b;
  9515. /*<       IF( INX1.EQ.2) GOTO 3 >*/
  9516.     if (*inx1 == 2) {
  9517.     goto L3;
  9518.     }
  9519. /*<    >*/
  9520.     gxx_(&z1, &rh, &b, &a2, xk, &ira, &gz1, &gzp1, &gr1, &grp1, &grk1, &gzz1);
  9521.  
  9522. /*<       GOTO 4 >*/
  9523.     goto L4;
  9524. /*<     3 CALL GX( Z1, RHX, XK, GZ1, GRK1) >*/
  9525. L3:
  9526.     gx_(&z1, rhx, xk, &gz1, &grk1);
  9527. /*<       GZP1= GRK1* Z1 >*/
  9528.     z__1.r = z1 * grk1.r, z__1.i = z1 * grk1.i;
  9529.     gzp1.r = z__1.r, gzp1.i = z__1.i;
  9530. /*<       GR1= GZ1/ RHX >*/
  9531.     z__1.r = gz1.r / *rhx, z__1.i = gz1.i / *rhx;
  9532.     gr1.r = z__1.r, gr1.i = z__1.i;
  9533. /*<       GRP1= GZP1/ RHX >*/
  9534.     z__1.r = gzp1.r / *rhx, z__1.i = gzp1.i / *rhx;
  9535.     grp1.r = z__1.r, grp1.i = z__1.i;
  9536. /*<       GRK1= GRK1* RHX >*/
  9537.     z__1.r = *rhx * grk1.r, z__1.i = *rhx * grk1.i;
  9538.     grk1.r = z__1.r, grk1.i = z__1.i;
  9539. /*<       GZZ1=(0.,0.) >*/
  9540.     gzz1.r = 0., gzz1.i = 0.;
  9541. /*<     4 IF( INX2.EQ.2) GOTO 5 >*/
  9542. L4:
  9543.     if (*inx2 == 2) {
  9544.     goto L5;
  9545.     }
  9546. /*<    >*/
  9547.     gxx_(&z2, &rh, &b, &a2, xk, &ira, &gz2, &gzp2, &gr2, &grp2, &grk2, &gzz2);
  9548.  
  9549. /*<       GOTO 6 >*/
  9550.     goto L6;
  9551. /*<     5 CALL GX( Z2, RHX, XK, GZ2, GRK2) >*/
  9552. L5:
  9553.     gx_(&z2, rhx, xk, &gz2, &grk2);
  9554. /*<       GZP2= GRK2* Z2 >*/
  9555.     z__1.r = z2 * grk2.r, z__1.i = z2 * grk2.i;
  9556.     gzp2.r = z__1.r, gzp2.i = z__1.i;
  9557. /*<       GR2= GZ2/ RHX >*/
  9558.     z__1.r = gz2.r / *rhx, z__1.i = gz2.i / *rhx;
  9559.     gr2.r = z__1.r, gr2.i = z__1.i;
  9560. /*<       GRP2= GZP2/ RHX >*/
  9561.     z__1.r = gzp2.r / *rhx, z__1.i = gzp2.i / *rhx;
  9562.     grp2.r = z__1.r, grp2.i = z__1.i;
  9563. /*<       GRK2= GRK2* RHX >*/
  9564.     z__1.r = *rhx * grk2.r, z__1.i = *rhx * grk2.i;
  9565.     grk2.r = z__1.r, grk2.i = z__1.i;
  9566. /*<       GZZ2=(0.,0.) >*/
  9567.     gzz2.r = 0., gzz2.i = 0.;
  9568. /*<     6 EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS) >*/
  9569. L6:
  9570.     z__5.r = gz2.r - gz1.r, z__5.i = gz2.i - gz1.i;
  9571.     z__4.r = cs * z__5.r, z__4.i = cs * z__5.i;
  9572.     z__3.r = *xk * z__4.r, z__3.i = *xk * z__4.i;
  9573.     z__7.r = gzp2.r + gzp1.r, z__7.i = gzp2.i + gzp1.i;
  9574.     z__6.r = ss * z__7.r, z__6.i = ss * z__7.i;
  9575.     z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
  9576.     z__1.r = con->r * z__2.r - con->i * z__2.i, z__1.i = con->r * z__2.i + 
  9577.         con->i * z__2.r;
  9578.     ezs->r = z__1.r, ezs->i = z__1.i;
  9579. /*<       EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS) >*/
  9580.     z__2.r = -con->r, z__2.i = -con->i;
  9581.     z__6.r = gz2.r + gz1.r, z__6.i = gz2.i + gz1.i;
  9582.     z__5.r = ss * z__6.r, z__5.i = ss * z__6.i;
  9583.     z__4.r = *xk * z__5.r, z__4.i = *xk * z__5.i;
  9584.     z__8.r = gzp2.r - gzp1.r, z__8.i = gzp2.i - gzp1.i;
  9585.     z__7.r = cs * z__8.r, z__7.i = cs * z__8.i;
  9586.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  9587.     z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + 
  9588.         z__2.i * z__3.r;
  9589.     ezc->r = z__1.r, ezc->i = z__1.i;
  9590. /*<    >*/
  9591.     z__2.r = -con->r, z__2.i = -con->i;
  9592.     z__8.r = z2 * grp2.r, z__8.i = z2 * grp2.i;
  9593.     z__9.r = z1 * grp1.r, z__9.i = z1 * grp1.i;
  9594.     z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i;
  9595.     z__6.r = z__7.r + gr2.r, z__6.i = z__7.i + gr2.i;
  9596.     z__5.r = z__6.r + gr1.r, z__5.i = z__6.i + gr1.i;
  9597.     z__4.r = ss * z__5.r, z__4.i = ss * z__5.i;
  9598.     z__13.r = z2 * gr2.r, z__13.i = z2 * gr2.i;
  9599.     z__14.r = z1 * gr1.r, z__14.i = z1 * gr1.i;
  9600.     z__12.r = z__13.r - z__14.r, z__12.i = z__13.i - z__14.i;
  9601.     z__11.r = cs * z__12.r, z__11.i = cs * z__12.i;
  9602.     z__10.r = *xk * z__11.r, z__10.i = *xk * z__11.i;
  9603.     z__3.r = z__4.r - z__10.r, z__3.i = z__4.i - z__10.i;
  9604.     z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + 
  9605.         z__2.i * z__3.r;
  9606.     ers->r = z__1.r, ers->i = z__1.i;
  9607. /*<    >*/
  9608.     z__2.r = -con->r, z__2.i = -con->i;
  9609.     z__8.r = z2 * grp2.r, z__8.i = z2 * grp2.i;
  9610.     z__9.r = z1 * grp1.r, z__9.i = z1 * grp1.i;
  9611.     z__7.r = z__8.r - z__9.r, z__7.i = z__8.i - z__9.i;
  9612.     z__6.r = z__7.r + gr2.r, z__6.i = z__7.i + gr2.i;
  9613.     z__5.r = z__6.r - gr1.r, z__5.i = z__6.i - gr1.i;
  9614.     z__4.r = cs * z__5.r, z__4.i = cs * z__5.i;
  9615.     z__13.r = z2 * gr2.r, z__13.i = z2 * gr2.i;
  9616.     z__14.r = z1 * gr1.r, z__14.i = z1 * gr1.i;
  9617.     z__12.r = z__13.r + z__14.r, z__12.i = z__13.i + z__14.i;
  9618.     z__11.r = ss * z__12.r, z__11.i = ss * z__12.i;
  9619.     z__10.r = *xk * z__11.r, z__10.i = *xk * z__11.i;
  9620.     z__3.r = z__4.r + z__10.r, z__3.i = z__4.i + z__10.i;
  9621.     z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + 
  9622.         z__2.i * z__3.r;
  9623.     erc->r = z__1.r, erc->i = z__1.i;
  9624. /*<       ERK= CON*( GRK2- GRK1) >*/
  9625.     z__2.r = grk2.r - grk1.r, z__2.i = grk2.i - grk1.i;
  9626.     z__1.r = con->r * z__2.r - con->i * z__2.i, z__1.i = con->r * z__2.i + 
  9627.         con->i * z__2.r;
  9628.     erk->r = z__1.r, erk->i = z__1.i;
  9629. /*<       CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT) >*/
  9630.     d__1 = -shk;
  9631.     intx_(&d__1, &shk, &rhk, ij, &cint, &sint);
  9632. /*<       BK= B* XK >*/
  9633.     bk = b * *xk;
  9634. /*<       BK2= BK* BK*.25 >*/
  9635.     d__1 = bk * bk;
  9636.     bk2 = d__1 * .25;
  9637. /*<    >*/
  9638.     z__2.r = -con->r, z__2.i = -con->i;
  9639.     z__5.r = gzp2.r - gzp1.r, z__5.i = gzp2.i - gzp1.i;
  9640.     d__2 = *xk * *xk;
  9641.     d__1 = d__2 * (1. - bk2);
  9642.     d__3 = -sint;
  9643.     z__7.r = cint, z__7.i = d__3;
  9644.     z__6.r = d__1 * z__7.r, z__6.i = d__1 * z__7.i;
  9645.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  9646.     z__9.r = gzz2.r - gzz1.r, z__9.i = gzz2.i - gzz1.i;
  9647.     z__8.r = bk2 * z__9.r, z__8.i = bk2 * z__9.i;
  9648.     z__3.r = z__4.r - z__8.r, z__3.i = z__4.i - z__8.i;
  9649.     z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + 
  9650.         z__2.i * z__3.r;
  9651.     ezk->r = z__1.r, ezk->i = z__1.i;
  9652. /*<       RETURN >*/
  9653.     return 0;
  9654. /*<       END >*/
  9655. } /* ekscx_ */
  9656.  
  9657. #undef con
  9658. #undef conx
  9659.  
  9660.  
  9661. /* *** */
  9662. /*     DOUBLE PRECISION 6/4/85 */
  9663.  
  9664. /*<       LOGICAL FUNCTION ENF( NUNIT) >*/
  9665. logical enf_(nunit)
  9666. integer *nunit;
  9667. {
  9668.     /* System generated locals */
  9669.     logical ret_val;
  9670.  
  9671. /* *** */
  9672. /* *********** THIS ROUTINE NOT USED ON VAX ************** */
  9673. /*     IF (EOF,NUNIT) 1,2 */
  9674. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  9675. /*<     1 ENF=.TRUE. >*/
  9676. /* L1: */
  9677.     ret_val = TRUE_;
  9678. /*<       RETURN >*/
  9679.     return ret_val;
  9680. /*<     2 ENF=.FALSE. >*/
  9681. /* L2: */
  9682.     ret_val = FALSE_;
  9683. /*<       RETURN >*/
  9684.     return ret_val;
  9685. /*<       END >*/
  9686. } /* enf_ */
  9687.  
  9688. /* *** */
  9689. /*     DOUBLE PRECISION 6/4/85 */
  9690.  
  9691. /*     IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
  9692. /* *** */
  9693. /*<       SUBROUTINE ERROR >*/
  9694. /* Subroutine */ int error_()
  9695. {
  9696.     /* Format strings */
  9697.     static char fmt_1[] = "(//,\002  ****  ERROR  ****   \002,//,5x,a,//)";
  9698.  
  9699.     /* System generated locals */
  9700.     integer i__1;
  9701.  
  9702.     /* Builtin functions */
  9703.     integer i_indx(), s_wsfe(), do_fio(), e_wsfe();
  9704.  
  9705.     /* Local variables */
  9706.     extern /* Subroutine */ int str0pc_();
  9707.     static integer msglen, ind;
  9708.     static char msg[80];
  9709.  
  9710.     /* Fortran I/O blocks */
  9711.     static cilist io___657 = { 0, 6, 0, fmt_1, 0 };
  9712.  
  9713.  
  9714. /*<       IMPLICIT INTEGER (A-Z) >*/
  9715. /*<       CHARACTER   MSG*80 >*/
  9716. /* JCB      CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,) */
  9717. /* JCB      CALL ERRSNS( FNUM, RMSSTS, RMSSTV, IUNIT, CNDVAL) */
  9718. /*<       CALL STR0PC( MSG, MSG) >*/
  9719.     str0pc_(msg, msg, 80L, 80L);
  9720. /*<       IND= INDEX( MSG,',') >*/
  9721.     ind = i_indx(msg, ",", 80L, 1L);
  9722. /*<       PRINT1 , MSG( IND+2: MSGLEN) >*/
  9723.     s_wsfe(&io___657);
  9724.     i__1 = ind + 1;
  9725.     do_fio(&c__1, msg + i__1, msglen - i__1);
  9726.     e_wsfe();
  9727. /*<     1 FORMAT(//,'  ****  ERROR  ****   ',//,5X,A,//) >*/
  9728. /*<       RETURN >*/
  9729.     return 0;
  9730. /*<       END >*/
  9731. } /* error_ */
  9732.  
  9733. /* *** */
  9734. /*     DOUBLE PRECISION 6/4/85 */
  9735.  
  9736. /*<       SUBROUTINE ETMNS( P1, P2, P3, P4, P5, P6, IPR, E) >*/
  9737. /* Subroutine */ int etmns_(p1, p2, p3, p4, p5, p6, ipr, e)
  9738. doublereal *p1, *p2, *p3, *p4, *p5, *p6;
  9739. integer *ipr;
  9740. doublecomplex *e;
  9741. {
  9742.     /* Initialized data */
  9743.  
  9744.     static doublereal tp = 6.283185308;
  9745.     static doublereal reta = .002654420938;
  9746.  
  9747.     /* System generated locals */
  9748.     integer i__1, i__2, i__3, i__4, i__5, i__6;
  9749.     doublereal d__1, d__2, d__3, d__4;
  9750.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
  9751.  
  9752.     /* Builtin functions */
  9753.     double cos(), sin();
  9754.     void z_sqrt(), z_div();
  9755.     double sqrt();
  9756.  
  9757.     /* Local variables */
  9758.     static integer i;
  9759.     static doublereal r;
  9760.     extern /* Subroutine */ int qdsrc_();
  9761.     static integer i1, i2, ii;
  9762.     static doublecomplex er;
  9763.     static doublereal ds;
  9764.     static doublecomplex et, cx, cy, cz;
  9765.     static integer is;
  9766.     static doublereal rs, px, py, pz, qx, qy, qz, wx, wy, wz;
  9767.     static doublecomplex tt1, tt2;
  9768. #define t1x ((doublereal *)&data_1 + 1800)
  9769. #define t1y ((doublereal *)&data_1 + 3000)
  9770. #define t1z ((doublereal *)&data_1 + 3600)
  9771. #define t2x ((doublereal *)&data_1 + 4201)
  9772. #define t2y ((doublereal *)&data_1 + 4601)
  9773. #define t2z ((doublereal *)&data_1 + 5001)
  9774. #define cab ((doublereal *)&data_1 + 3000)
  9775. #define sab ((doublereal *)&data_1 + 3600)
  9776.     static doublereal arg, cph, cet;
  9777.     static doublecomplex erh;
  9778.     static doublereal cth, dsh;
  9779.     static integer neq;
  9780.     static doublecomplex ezh, rrh;
  9781.     static doublereal sph, sth, set;
  9782.     static integer npm;
  9783.     static doublecomplex rrv;
  9784.  
  9785. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  9786. /* *** */
  9787.  
  9788. /*     ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD */
  9789. /*     INCIDENT ON THE STRUCTURE.  E IS THE RIGHT HAND SIDE OF THE MATRIX 
  9790. */
  9791. /*     EQUATION. */
  9792.  
  9793. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  9794. /*<    >*/
  9795. /*<    >*/
  9796. /*<       COMMON  /ANGL/ SALP( NM) >*/
  9797. /*<    >*/
  9798. /*<    >*/
  9799. /*<       DIMENSION  CAB(1), SAB(1), E( N2M) >*/
  9800. /*<       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
  9801. /*<       EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
  9802. /*<    >*/
  9803. /*<       DATA   TP/6.283185308D+0/, RETA/2.654420938D-3/ >*/
  9804.     /* Parameter adjustments */
  9805.     --e;
  9806.  
  9807.     /* Function Body */
  9808. /*<       NEQ= N+2* M >*/
  9809.     neq = data_1.n + (data_1.m << 1);
  9810. /*<       NQDS=0 >*/
  9811.     vsorc_1.nqds = 0;
  9812.  
  9813. /*     APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE */
  9814.  
  9815. /*<       IF( IPR.GT.0.AND. IPR.NE.5) GOTO 5 >*/
  9816.     if (*ipr > 0 && *ipr != 5) {
  9817.     goto L5;
  9818.     }
  9819. /*<       DO 1  I=1, NEQ >*/
  9820.     i__1 = neq;
  9821.     for (i = 1; i <= i__1; ++i) {
  9822. /*<     1 E( I)=(0.,0.) >*/
  9823. /* L1: */
  9824.     i__2 = i;
  9825.     e[i__2].r = 0., e[i__2].i = 0.;
  9826.     }
  9827. /*<       IF( NSANT.EQ.0) GOTO 3 >*/
  9828.     if (vsorc_1.nsant == 0) {
  9829.     goto L3;
  9830.     }
  9831. /*<       DO 2  I=1, NSANT >*/
  9832.     i__2 = vsorc_1.nsant;
  9833.     for (i = 1; i <= i__2; ++i) {
  9834. /*<       IS= ISANT( I) >*/
  9835.     is = vsorc_1.isant[i - 1];
  9836. /*<     2 E( IS)=- VSANT( I)/( SI( IS)* WLAM) >*/
  9837. /* L2: */
  9838.     i__1 = is;
  9839.     i__3 = i - 1;
  9840.     z__2.r = -vsorc_1.vsant[i__3].r, z__2.i = -vsorc_1.vsant[i__3].i;
  9841.     d__1 = data_1.si[is - 1] * data_1.wlam;
  9842.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  9843.     e[i__1].r = z__1.r, e[i__1].i = z__1.i;
  9844.     }
  9845. /*<     3 IF( NVQD.EQ.0) RETURN >*/
  9846. L3:
  9847.     if (vsorc_1.nvqd == 0) {
  9848.     return 0;
  9849.     }
  9850. /*<       DO 4  I=1, NVQD >*/
  9851.     i__1 = vsorc_1.nvqd;
  9852.     for (i = 1; i <= i__1; ++i) {
  9853. /*<       IS= IVQD( I) >*/
  9854.     is = vsorc_1.ivqd[i - 1];
  9855. /*<     4 CALL QDSRC( IS, VQD( I), E) >*/
  9856. /* L4: */
  9857.     qdsrc_(&is, &vsorc_1.vqd[i - 1], &e[1]);
  9858.     }
  9859. /*<       RETURN >*/
  9860.     return 0;
  9861.  
  9862. /*     INCIDENT PLANE WAVE, LINEARLY POLARIZED. */
  9863.  
  9864. /*<     5 IF( IPR.GT.3) GOTO 19 >*/
  9865. L5:
  9866.     if (*ipr > 3) {
  9867.     goto L19;
  9868.     }
  9869. /*<       CTH= COS( P1) >*/
  9870.     cth = cos(*p1);
  9871. /*<       STH= SIN( P1) >*/
  9872.     sth = sin(*p1);
  9873. /*<       CPH= COS( P2) >*/
  9874.     cph = cos(*p2);
  9875. /*<       SPH= SIN( P2) >*/
  9876.     sph = sin(*p2);
  9877. /*<       CET= COS( P3) >*/
  9878.     cet = cos(*p3);
  9879. /*<       SET= SIN( P3) >*/
  9880.     set = sin(*p3);
  9881. /*<       PX= CTH* CPH* CET- SPH* SET >*/
  9882.     d__1 = cth * cph;
  9883.     px = d__1 * cet - sph * set;
  9884. /*<       PY= CTH* SPH* CET+ CPH* SET >*/
  9885.     d__1 = cth * sph;
  9886.     py = d__1 * cet + cph * set;
  9887. /*<       PZ=- STH* CET >*/
  9888.     pz = -sth * cet;
  9889. /*<       WX=- STH* CPH >*/
  9890.     wx = -sth * cph;
  9891. /*<       WY=- STH* SPH >*/
  9892.     wy = -sth * sph;
  9893. /*<       WZ=- CTH >*/
  9894.     wz = -cth;
  9895. /*<       QX= WY* PZ- WZ* PY >*/
  9896.     qx = wy * pz - wz * py;
  9897. /*<       QY= WZ* PX- WX* PZ >*/
  9898.     qy = wz * px - wx * pz;
  9899. /*<       QZ= WX* PY- WY* PX >*/
  9900.     qz = wx * py - wy * px;
  9901. /*<       IF( KSYMP.EQ.1) GOTO 7 >*/
  9902.     if (gnd_1.ksymp == 1) {
  9903.     goto L7;
  9904.     }
  9905. /*<       IF( IPERF.EQ.1) GOTO 6 >*/
  9906.     if (gnd_1.iperf == 1) {
  9907.     goto L6;
  9908.     }
  9909. /*<       RRV= SQRT(1.- ZRATI* ZRATI* STH* STH) >*/
  9910.     z__5.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i * gnd_1.zrati.i, 
  9911.         z__5.i = gnd_1.zrati.r * gnd_1.zrati.i + gnd_1.zrati.i * 
  9912.         gnd_1.zrati.r;
  9913.     z__4.r = sth * z__5.r, z__4.i = sth * z__5.i;
  9914.     z__3.r = sth * z__4.r, z__3.i = sth * z__4.i;
  9915.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  9916.     z_sqrt(&z__1, &z__2);
  9917.     rrv.r = z__1.r, rrv.i = z__1.i;
  9918. /*<       RRH= ZRATI* CTH >*/
  9919.     z__1.r = cth * gnd_1.zrati.r, z__1.i = cth * gnd_1.zrati.i;
  9920.     rrh.r = z__1.r, rrh.i = z__1.i;
  9921. /*<       RRH=( RRH- RRV)/( RRH+ RRV) >*/
  9922.     z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
  9923.     z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
  9924.     z_div(&z__1, &z__2, &z__3);
  9925.     rrh.r = z__1.r, rrh.i = z__1.i;
  9926. /*<       RRV= ZRATI* RRV >*/
  9927.     z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i = 
  9928.         gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
  9929.     rrv.r = z__1.r, rrv.i = z__1.i;
  9930. /*<       RRV=-( CTH- RRV)/( CTH+ RRV) >*/
  9931.     z__3.r = cth - rrv.r, z__3.i = -rrv.i;
  9932.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  9933.     z__4.r = cth + rrv.r, z__4.i = rrv.i;
  9934.     z_div(&z__1, &z__2, &z__4);
  9935.     rrv.r = z__1.r, rrv.i = z__1.i;
  9936. /*<       GOTO 7 >*/
  9937.     goto L7;
  9938. /*<     6 RRV=-(1.,0.) >*/
  9939. L6:
  9940.     rrv.r = -1., rrv.i = 0.;
  9941. /*<       RRH=-(1.,0.) >*/
  9942.     rrh.r = -1., rrh.i = 0.;
  9943. /*<     7 IF( IPR.GT.1) GOTO 13 >*/
  9944. L7:
  9945.     if (*ipr > 1) {
  9946.     goto L13;
  9947.     }
  9948. /*<       IF( N.EQ.0) GOTO 10 >*/
  9949.     if (data_1.n == 0) {
  9950.     goto L10;
  9951.     }
  9952. /*<       DO 8  I=1, N >*/
  9953.     i__1 = data_1.n;
  9954.     for (i = 1; i <= i__1; ++i) {
  9955. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
  9956.     d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
  9957.     arg = -tp * (d__1 + wz * data_1.z[i - 1]);
  9958. /*<    >*/
  9959. /* L8: */
  9960.     i__3 = i;
  9961.     d__2 = px * cab[i - 1] + py * sab[i - 1];
  9962.     d__1 = -(d__2 + pz * angl_1.salp[i - 1]);
  9963.     d__3 = cos(arg);
  9964.     d__4 = sin(arg);
  9965.     z__2.r = d__3, z__2.i = d__4;
  9966.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  9967.     e[i__3].r = z__1.r, e[i__3].i = z__1.i;
  9968.     }
  9969. /*<       IF( KSYMP.EQ.1) GOTO 10 >*/
  9970.     if (gnd_1.ksymp == 1) {
  9971.     goto L10;
  9972.     }
  9973. /*<       TT1=( PY* CPH- PX* SPH)*( RRH- RRV) >*/
  9974.     d__1 = py * cph - px * sph;
  9975.     z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
  9976.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  9977.     tt1.r = z__1.r, tt1.i = z__1.i;
  9978. /*<       CX= RRV* PX- TT1* SPH >*/
  9979.     z__2.r = px * rrv.r, z__2.i = px * rrv.i;
  9980.     z__3.r = sph * tt1.r, z__3.i = sph * tt1.i;
  9981.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  9982.     cx.r = z__1.r, cx.i = z__1.i;
  9983. /*<       CY= RRV* PY+ TT1* CPH >*/
  9984.     z__2.r = py * rrv.r, z__2.i = py * rrv.i;
  9985.     z__3.r = cph * tt1.r, z__3.i = cph * tt1.i;
  9986.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  9987.     cy.r = z__1.r, cy.i = z__1.i;
  9988. /*<       CZ=- RRV* PZ >*/
  9989.     z__2.r = -rrv.r, z__2.i = -rrv.i;
  9990.     z__1.r = pz * z__2.r, z__1.i = pz * z__2.i;
  9991.     cz.r = z__1.r, cz.i = z__1.i;
  9992. /*<       DO 9  I=1, N >*/
  9993.     i__3 = data_1.n;
  9994.     for (i = 1; i <= i__3; ++i) {
  9995. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
  9996.     arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz * 
  9997.         data_1.z[i - 1]);
  9998. /*<    >*/
  9999. /* L9: */
  10000.     i__1 = i;
  10001.     i__2 = i;
  10002.     i__4 = i - 1;
  10003.     z__5.r = cab[i__4] * cx.r, z__5.i = cab[i__4] * cx.i;
  10004.     i__5 = i - 1;
  10005.     z__6.r = sab[i__5] * cy.r, z__6.i = sab[i__5] * cy.i;
  10006.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  10007.     i__6 = i - 1;
  10008.     z__7.r = angl_1.salp[i__6] * cz.r, z__7.i = angl_1.salp[i__6] * cz.i;
  10009.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  10010.     d__1 = cos(arg);
  10011.     d__2 = sin(arg);
  10012.     z__8.r = d__1, z__8.i = d__2;
  10013.     z__2.r = z__3.r * z__8.r - z__3.i * z__8.i, z__2.i = z__3.r * z__8.i 
  10014.         + z__3.i * z__8.r;
  10015.     z__1.r = e[i__2].r - z__2.r, z__1.i = e[i__2].i - z__2.i;
  10016.     e[i__1].r = z__1.r, e[i__1].i = z__1.i;
  10017.     }
  10018. /*<    10 IF( M.EQ.0) RETURN >*/
  10019. L10:
  10020.     if (data_1.m == 0) {
  10021.     return 0;
  10022.     }
  10023. /*<       I= LD+1 >*/
  10024.     i = data_1.ld + 1;
  10025. /*<       I1= N-1 >*/
  10026.     i1 = data_1.n - 1;
  10027. /*<       DO 11  IS=1, M >*/
  10028.     i__1 = data_1.m;
  10029.     for (is = 1; is <= i__1; ++is) {
  10030. /*<       I= I-1 >*/
  10031.     --i;
  10032. /*<       I1= I1+2 >*/
  10033.     i1 += 2;
  10034. /*<       I2= I1+1 >*/
  10035.     i2 = i1 + 1;
  10036. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
  10037.     d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
  10038.     arg = -tp * (d__1 + wz * data_1.z[i - 1]);
  10039. /*<       TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
  10040.     d__1 = cos(arg);
  10041.     d__2 = sin(arg);
  10042.     z__3.r = d__1, z__3.i = d__2;
  10043.     i__2 = i - 1;
  10044.     z__2.r = angl_1.salp[i__2] * z__3.r, z__2.i = angl_1.salp[i__2] * 
  10045.         z__3.i;
  10046.     z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
  10047.     tt1.r = z__1.r, tt1.i = z__1.i;
  10048. /*<       E( I2)=( QX* T1X( I)+ QY* T1Y( I)+ QZ* T1Z( I))* TT1 >*/
  10049.     i__2 = i2;
  10050.     d__2 = qx * t1x[i - 1] + qy * t1y[i - 1];
  10051.     d__1 = d__2 + qz * t1z[i - 1];
  10052.     z__1.r = d__1 * tt1.r, z__1.i = d__1 * tt1.i;
  10053.     e[i__2].r = z__1.r, e[i__2].i = z__1.i;
  10054. /*<    11 E( I1)=( QX* T2X( I)+ QY* T2Y( I)+ QZ* T2Z( I))* TT1 >*/
  10055. /* L11: */
  10056.     i__2 = i1;
  10057.     d__2 = qx * t2x[i - 1] + qy * t2y[i - 1];
  10058.     d__1 = d__2 + qz * t2z[i - 1];
  10059.     z__1.r = d__1 * tt1.r, z__1.i = d__1 * tt1.i;
  10060.     e[i__2].r = z__1.r, e[i__2].i = z__1.i;
  10061.     }
  10062. /*<       IF( KSYMP.EQ.1) RETURN >*/
  10063.     if (gnd_1.ksymp == 1) {
  10064.     return 0;
  10065.     }
  10066. /*<       TT1=( QY* CPH- QX* SPH)*( RRV- RRH) >*/
  10067.     d__1 = qy * cph - qx * sph;
  10068.     z__2.r = rrv.r - rrh.r, z__2.i = rrv.i - rrh.i;
  10069.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  10070.     tt1.r = z__1.r, tt1.i = z__1.i;
  10071. /*<       CX=-( RRH* QX- TT1* SPH) >*/
  10072.     z__3.r = qx * rrh.r, z__3.i = qx * rrh.i;
  10073.     z__4.r = sph * tt1.r, z__4.i = sph * tt1.i;
  10074.     z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
  10075.     z__1.r = -z__2.r, z__1.i = -z__2.i;
  10076.     cx.r = z__1.r, cx.i = z__1.i;
  10077. /*<       CY=-( RRH* QY+ TT1* CPH) >*/
  10078.     z__3.r = qy * rrh.r, z__3.i = qy * rrh.i;
  10079.     z__4.r = cph * tt1.r, z__4.i = cph * tt1.i;
  10080.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  10081.     z__1.r = -z__2.r, z__1.i = -z__2.i;
  10082.     cy.r = z__1.r, cy.i = z__1.i;
  10083. /*<       CZ= RRH* QZ >*/
  10084.     z__1.r = qz * rrh.r, z__1.i = qz * rrh.i;
  10085.     cz.r = z__1.r, cz.i = z__1.i;
  10086. /*<       I= LD+1 >*/
  10087.     i = data_1.ld + 1;
  10088. /*<       I1= N-1 >*/
  10089.     i1 = data_1.n - 1;
  10090. /*<       DO 12  IS=1, M >*/
  10091.     i__2 = data_1.m;
  10092.     for (is = 1; is <= i__2; ++is) {
  10093. /*<       I= I-1 >*/
  10094.     --i;
  10095. /*<       I1= I1+2 >*/
  10096.     i1 += 2;
  10097. /*<       I2= I1+1 >*/
  10098.     i2 = i1 + 1;
  10099. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
  10100.     arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz * 
  10101.         data_1.z[i - 1]);
  10102. /*<       TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
  10103.     d__1 = cos(arg);
  10104.     d__2 = sin(arg);
  10105.     z__3.r = d__1, z__3.i = d__2;
  10106.     i__1 = i - 1;
  10107.     z__2.r = angl_1.salp[i__1] * z__3.r, z__2.i = angl_1.salp[i__1] * 
  10108.         z__3.i;
  10109.     z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
  10110.     tt1.r = z__1.r, tt1.i = z__1.i;
  10111. /*<       E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1 >*/
  10112.     i__1 = i2;
  10113.     i__4 = i2;
  10114.     i__5 = i - 1;
  10115.     z__5.r = t1x[i__5] * cx.r, z__5.i = t1x[i__5] * cx.i;
  10116.     i__6 = i - 1;
  10117.     z__6.r = t1y[i__6] * cy.r, z__6.i = t1y[i__6] * cy.i;
  10118.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  10119.     i__3 = i - 1;
  10120.     z__7.r = t1z[i__3] * cz.r, z__7.i = t1z[i__3] * cz.i;
  10121.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  10122.     z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i + 
  10123.         z__3.i * tt1.r;
  10124.     z__1.r = e[i__4].r + z__2.r, z__1.i = e[i__4].i + z__2.i;
  10125.     e[i__1].r = z__1.r, e[i__1].i = z__1.i;
  10126. /*<    12 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1 >*/
  10127. /* L12: */
  10128.     i__1 = i1;
  10129.     i__4 = i1;
  10130.     i__5 = i - 1;
  10131.     z__5.r = t2x[i__5] * cx.r, z__5.i = t2x[i__5] * cx.i;
  10132.     i__6 = i - 1;
  10133.     z__6.r = t2y[i__6] * cy.r, z__6.i = t2y[i__6] * cy.i;
  10134.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  10135.     i__3 = i - 1;
  10136.     z__7.r = t2z[i__3] * cz.r, z__7.i = t2z[i__3] * cz.i;
  10137.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  10138.     z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i + 
  10139.         z__3.i * tt1.r;
  10140.     z__1.r = e[i__4].r + z__2.r, z__1.i = e[i__4].i + z__2.i;
  10141.     e[i__1].r = z__1.r, e[i__1].i = z__1.i;
  10142.     }
  10143.  
  10144. /*     INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION. */
  10145.  
  10146. /*<       RETURN >*/
  10147.     return 0;
  10148. /*<    13 TT1=-(0.,1.)* P6 >*/
  10149. L13:
  10150.     z__1.r = *p6 * 0., z__1.i = *p6 * -1.;
  10151.     tt1.r = z__1.r, tt1.i = z__1.i;
  10152. /*<       IF( IPR.EQ.3) TT1=- TT1 >*/
  10153.     if (*ipr == 3) {
  10154.     z__1.r = -tt1.r, z__1.i = -tt1.i;
  10155.     tt1.r = z__1.r, tt1.i = z__1.i;
  10156.     }
  10157. /*<       IF( N.EQ.0) GOTO 16 >*/
  10158.     if (data_1.n == 0) {
  10159.     goto L16;
  10160.     }
  10161. /*<       CX= PX+ TT1* QX >*/
  10162.     z__2.r = qx * tt1.r, z__2.i = qx * tt1.i;
  10163.     z__1.r = px + z__2.r, z__1.i = z__2.i;
  10164.     cx.r = z__1.r, cx.i = z__1.i;
  10165. /*<       CY= PY+ TT1* QY >*/
  10166.     z__2.r = qy * tt1.r, z__2.i = qy * tt1.i;
  10167.     z__1.r = py + z__2.r, z__1.i = z__2.i;
  10168.     cy.r = z__1.r, cy.i = z__1.i;
  10169. /*<       CZ= PZ+ TT1* QZ >*/
  10170.     z__2.r = qz * tt1.r, z__2.i = qz * tt1.i;
  10171.     z__1.r = pz + z__2.r, z__1.i = z__2.i;
  10172.     cz.r = z__1.r, cz.i = z__1.i;
  10173. /*<       DO 14  I=1, N >*/
  10174.     i__1 = data_1.n;
  10175.     for (i = 1; i <= i__1; ++i) {
  10176. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
  10177.     d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
  10178.     arg = -tp * (d__1 + wz * data_1.z[i - 1]);
  10179. /*<    >*/
  10180. /* L14: */
  10181.     i__4 = i;
  10182.     i__5 = i - 1;
  10183.     z__5.r = cab[i__5] * cx.r, z__5.i = cab[i__5] * cx.i;
  10184.     i__6 = i - 1;
  10185.     z__6.r = sab[i__6] * cy.r, z__6.i = sab[i__6] * cy.i;
  10186.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  10187.     i__3 = i - 1;
  10188.     z__7.r = angl_1.salp[i__3] * cz.r, z__7.i = angl_1.salp[i__3] * cz.i;
  10189.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  10190.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  10191.     d__1 = cos(arg);
  10192.     d__2 = sin(arg);
  10193.     z__8.r = d__1, z__8.i = d__2;
  10194.     z__1.r = z__2.r * z__8.r - z__2.i * z__8.i, z__1.i = z__2.r * z__8.i 
  10195.         + z__2.i * z__8.r;
  10196.     e[i__4].r = z__1.r, e[i__4].i = z__1.i;
  10197.     }
  10198. /*<       IF( KSYMP.EQ.1) GOTO 16 >*/
  10199.     if (gnd_1.ksymp == 1) {
  10200.     goto L16;
  10201.     }
  10202. /*<       TT2=( CY* CPH- CX* SPH)*( RRH- RRV) >*/
  10203.     z__3.r = cph * cy.r, z__3.i = cph * cy.i;
  10204.     z__4.r = sph * cx.r, z__4.i = sph * cx.i;
  10205.     z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
  10206.     z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
  10207.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i + 
  10208.         z__2.i * z__5.r;
  10209.     tt2.r = z__1.r, tt2.i = z__1.i;
  10210. /*<       CX= RRV* CX- TT2* SPH >*/
  10211.     z__2.r = rrv.r * cx.r - rrv.i * cx.i, z__2.i = rrv.r * cx.i + rrv.i * 
  10212.         cx.r;
  10213.     z__3.r = sph * tt2.r, z__3.i = sph * tt2.i;
  10214.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  10215.     cx.r = z__1.r, cx.i = z__1.i;
  10216. /*<       CY= RRV* CY+ TT2* CPH >*/
  10217.     z__2.r = rrv.r * cy.r - rrv.i * cy.i, z__2.i = rrv.r * cy.i + rrv.i * 
  10218.         cy.r;
  10219.     z__3.r = cph * tt2.r, z__3.i = cph * tt2.i;
  10220.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  10221.     cy.r = z__1.r, cy.i = z__1.i;
  10222. /*<       CZ=- RRV* CZ >*/
  10223.     z__2.r = -rrv.r, z__2.i = -rrv.i;
  10224.     z__1.r = z__2.r * cz.r - z__2.i * cz.i, z__1.i = z__2.r * cz.i + z__2.i * 
  10225.         cz.r;
  10226.     cz.r = z__1.r, cz.i = z__1.i;
  10227. /*<       DO 15  I=1, N >*/
  10228.     i__4 = data_1.n;
  10229.     for (i = 1; i <= i__4; ++i) {
  10230. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
  10231.     arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz * 
  10232.         data_1.z[i - 1]);
  10233. /*<    >*/
  10234. /* L15: */
  10235.     i__5 = i;
  10236.     i__6 = i;
  10237.     i__3 = i - 1;
  10238.     z__5.r = cab[i__3] * cx.r, z__5.i = cab[i__3] * cx.i;
  10239.     i__1 = i - 1;
  10240.     z__6.r = sab[i__1] * cy.r, z__6.i = sab[i__1] * cy.i;
  10241.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  10242.     i__2 = i - 1;
  10243.     z__7.r = angl_1.salp[i__2] * cz.r, z__7.i = angl_1.salp[i__2] * cz.i;
  10244.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  10245.     d__1 = cos(arg);
  10246.     d__2 = sin(arg);
  10247.     z__8.r = d__1, z__8.i = d__2;
  10248.     z__2.r = z__3.r * z__8.r - z__3.i * z__8.i, z__2.i = z__3.r * z__8.i 
  10249.         + z__3.i * z__8.r;
  10250.     z__1.r = e[i__6].r - z__2.r, z__1.i = e[i__6].i - z__2.i;
  10251.     e[i__5].r = z__1.r, e[i__5].i = z__1.i;
  10252.     }
  10253. /*<    16 IF( M.EQ.0) RETURN >*/
  10254. L16:
  10255.     if (data_1.m == 0) {
  10256.     return 0;
  10257.     }
  10258. /*<       CX= QX- TT1* PX >*/
  10259.     z__2.r = px * tt1.r, z__2.i = px * tt1.i;
  10260.     z__1.r = qx - z__2.r, z__1.i = -z__2.i;
  10261.     cx.r = z__1.r, cx.i = z__1.i;
  10262. /*<       CY= QY- TT1* PY >*/
  10263.     z__2.r = py * tt1.r, z__2.i = py * tt1.i;
  10264.     z__1.r = qy - z__2.r, z__1.i = -z__2.i;
  10265.     cy.r = z__1.r, cy.i = z__1.i;
  10266. /*<       CZ= QZ- TT1* PZ >*/
  10267.     z__2.r = pz * tt1.r, z__2.i = pz * tt1.i;
  10268.     z__1.r = qz - z__2.r, z__1.i = -z__2.i;
  10269.     cz.r = z__1.r, cz.i = z__1.i;
  10270. /*<       I= LD+1 >*/
  10271.     i = data_1.ld + 1;
  10272. /*<       I1= N-1 >*/
  10273.     i1 = data_1.n - 1;
  10274. /*<       DO 17  IS=1, M >*/
  10275.     i__5 = data_1.m;
  10276.     for (is = 1; is <= i__5; ++is) {
  10277. /*<       I= I-1 >*/
  10278.     --i;
  10279. /*<       I1= I1+2 >*/
  10280.     i1 += 2;
  10281. /*<       I2= I1+1 >*/
  10282.     i2 = i1 + 1;
  10283. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
  10284.     d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
  10285.     arg = -tp * (d__1 + wz * data_1.z[i - 1]);
  10286. /*<       TT2= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
  10287.     d__1 = cos(arg);
  10288.     d__2 = sin(arg);
  10289.     z__3.r = d__1, z__3.i = d__2;
  10290.     i__6 = i - 1;
  10291.     z__2.r = angl_1.salp[i__6] * z__3.r, z__2.i = angl_1.salp[i__6] * 
  10292.         z__3.i;
  10293.     z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
  10294.     tt2.r = z__1.r, tt2.i = z__1.i;
  10295. /*<       E( I2)=( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT2 >*/
  10296.     i__6 = i2;
  10297.     i__3 = i - 1;
  10298.     z__4.r = t1x[i__3] * cx.r, z__4.i = t1x[i__3] * cx.i;
  10299.     i__1 = i - 1;
  10300.     z__5.r = t1y[i__1] * cy.r, z__5.i = t1y[i__1] * cy.i;
  10301.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  10302.     i__2 = i - 1;
  10303.     z__6.r = t1z[i__2] * cz.r, z__6.i = t1z[i__2] * cz.i;
  10304.     z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  10305.     z__1.r = z__2.r * tt2.r - z__2.i * tt2.i, z__1.i = z__2.r * tt2.i + 
  10306.         z__2.i * tt2.r;
  10307.     e[i__6].r = z__1.r, e[i__6].i = z__1.i;
  10308. /*<    17 E( I1)=( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT2 >*/
  10309. /* L17: */
  10310.     i__6 = i1;
  10311.     i__3 = i - 1;
  10312.     z__4.r = t2x[i__3] * cx.r, z__4.i = t2x[i__3] * cx.i;
  10313.     i__1 = i - 1;
  10314.     z__5.r = t2y[i__1] * cy.r, z__5.i = t2y[i__1] * cy.i;
  10315.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  10316.     i__2 = i - 1;
  10317.     z__6.r = t2z[i__2] * cz.r, z__6.i = t2z[i__2] * cz.i;
  10318.     z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  10319.     z__1.r = z__2.r * tt2.r - z__2.i * tt2.i, z__1.i = z__2.r * tt2.i + 
  10320.         z__2.i * tt2.r;
  10321.     e[i__6].r = z__1.r, e[i__6].i = z__1.i;
  10322.     }
  10323. /*<       IF( KSYMP.EQ.1) RETURN >*/
  10324.     if (gnd_1.ksymp == 1) {
  10325.     return 0;
  10326.     }
  10327. /*<       TT1=( CY* CPH- CX* SPH)*( RRV- RRH) >*/
  10328.     z__3.r = cph * cy.r, z__3.i = cph * cy.i;
  10329.     z__4.r = sph * cx.r, z__4.i = sph * cx.i;
  10330.     z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
  10331.     z__5.r = rrv.r - rrh.r, z__5.i = rrv.i - rrh.i;
  10332.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i + 
  10333.         z__2.i * z__5.r;
  10334.     tt1.r = z__1.r, tt1.i = z__1.i;
  10335. /*<       CX=-( RRH* CX- TT1* SPH) >*/
  10336.     z__3.r = rrh.r * cx.r - rrh.i * cx.i, z__3.i = rrh.r * cx.i + rrh.i * 
  10337.         cx.r;
  10338.     z__4.r = sph * tt1.r, z__4.i = sph * tt1.i;
  10339.     z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
  10340.     z__1.r = -z__2.r, z__1.i = -z__2.i;
  10341.     cx.r = z__1.r, cx.i = z__1.i;
  10342. /*<       CY=-( RRH* CY+ TT1* CPH) >*/
  10343.     z__3.r = rrh.r * cy.r - rrh.i * cy.i, z__3.i = rrh.r * cy.i + rrh.i * 
  10344.         cy.r;
  10345.     z__4.r = cph * tt1.r, z__4.i = cph * tt1.i;
  10346.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  10347.     z__1.r = -z__2.r, z__1.i = -z__2.i;
  10348.     cy.r = z__1.r, cy.i = z__1.i;
  10349. /*<       CZ= RRH* CZ >*/
  10350.     z__1.r = rrh.r * cz.r - rrh.i * cz.i, z__1.i = rrh.r * cz.i + rrh.i * 
  10351.         cz.r;
  10352.     cz.r = z__1.r, cz.i = z__1.i;
  10353. /*<       I= LD+1 >*/
  10354.     i = data_1.ld + 1;
  10355. /*<       I1= N-1 >*/
  10356.     i1 = data_1.n - 1;
  10357. /*<       DO 18  IS=1, M >*/
  10358.     i__6 = data_1.m;
  10359.     for (is = 1; is <= i__6; ++is) {
  10360. /*<       I= I-1 >*/
  10361.     --i;
  10362. /*<       I1= I1+2 >*/
  10363.     i1 += 2;
  10364. /*<       I2= I1+1 >*/
  10365.     i2 = i1 + 1;
  10366. /*<       ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
  10367.     arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz * 
  10368.         data_1.z[i - 1]);
  10369. /*<       TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
  10370.     d__1 = cos(arg);
  10371.     d__2 = sin(arg);
  10372.     z__3.r = d__1, z__3.i = d__2;
  10373.     i__3 = i - 1;
  10374.     z__2.r = angl_1.salp[i__3] * z__3.r, z__2.i = angl_1.salp[i__3] * 
  10375.         z__3.i;
  10376.     z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
  10377.     tt1.r = z__1.r, tt1.i = z__1.i;
  10378. /*<       E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1 >*/
  10379.     i__3 = i2;
  10380.     i__1 = i2;
  10381.     i__2 = i - 1;
  10382.     z__5.r = t1x[i__2] * cx.r, z__5.i = t1x[i__2] * cx.i;
  10383.     i__5 = i - 1;
  10384.     z__6.r = t1y[i__5] * cy.r, z__6.i = t1y[i__5] * cy.i;
  10385.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  10386.     i__4 = i - 1;
  10387.     z__7.r = t1z[i__4] * cz.r, z__7.i = t1z[i__4] * cz.i;
  10388.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  10389.     z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i + 
  10390.         z__3.i * tt1.r;
  10391.     z__1.r = e[i__1].r + z__2.r, z__1.i = e[i__1].i + z__2.i;
  10392.     e[i__3].r = z__1.r, e[i__3].i = z__1.i;
  10393. /*<    18 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1 >*/
  10394. /* L18: */
  10395.     i__3 = i1;
  10396.     i__1 = i1;
  10397.     i__2 = i - 1;
  10398.     z__5.r = t2x[i__2] * cx.r, z__5.i = t2x[i__2] * cx.i;
  10399.     i__5 = i - 1;
  10400.     z__6.r = t2y[i__5] * cy.r, z__6.i = t2y[i__5] * cy.i;
  10401.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  10402.     i__4 = i - 1;
  10403.     z__7.r = t2z[i__4] * cz.r, z__7.i = t2z[i__4] * cz.i;
  10404.     z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  10405.     z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i + 
  10406.         z__3.i * tt1.r;
  10407.     z__1.r = e[i__1].r + z__2.r, z__1.i = e[i__1].i + z__2.i;
  10408.     e[i__3].r = z__1.r, e[i__3].i = z__1.i;
  10409.     }
  10410.  
  10411. /*     INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE. */
  10412.  
  10413. /*<       RETURN >*/
  10414.     return 0;
  10415. /*<    19 WZ= COS( P4) >*/
  10416. L19:
  10417.     wz = cos(*p4);
  10418. /*<       WX= WZ* COS( P5) >*/
  10419.     wx = wz * cos(*p5);
  10420. /*<       WY= WZ* SIN( P5) >*/
  10421.     wy = wz * sin(*p5);
  10422. /*<       WZ= SIN( P4) >*/
  10423.     wz = sin(*p4);
  10424. /*<       DS= P6*59.958 >*/
  10425.     ds = *p6 * 59.958;
  10426. /*<       DSH= P6/(2.* TP) >*/
  10427.     dsh = *p6 / (tp * 2.);
  10428. /*<       NPM= N+ M >*/
  10429.     npm = data_1.n + data_1.m;
  10430. /*<       IS= LD+1 >*/
  10431.     is = data_1.ld + 1;
  10432. /*<       I1= N-1 >*/
  10433.     i1 = data_1.n - 1;
  10434. /*<       DO 24  I=1, NPM >*/
  10435.     i__3 = npm;
  10436.     for (i = 1; i <= i__3; ++i) {
  10437. /*<       II= I >*/
  10438.     ii = i;
  10439. /*<       IF( I.LE. N) GOTO 20 >*/
  10440.     if (i <= data_1.n) {
  10441.         goto L20;
  10442.     }
  10443. /*<       IS= IS-1 >*/
  10444.     --is;
  10445. /*<       II= IS >*/
  10446.     ii = is;
  10447. /*<       I1= I1+2 >*/
  10448.     i1 += 2;
  10449. /*<       I2= I1+1 >*/
  10450.     i2 = i1 + 1;
  10451. /*<    20 PX= X( II)- P1 >*/
  10452. L20:
  10453.     px = data_1.x[ii - 1] - *p1;
  10454. /*<       PY= Y( II)- P2 >*/
  10455.     py = data_1.y[ii - 1] - *p2;
  10456. /*<       PZ= Z( II)- P3 >*/
  10457.     pz = data_1.z[ii - 1] - *p3;
  10458. /*<       RS= PX* PX+ PY* PY+ PZ* PZ >*/
  10459.     d__1 = px * px + py * py;
  10460.     rs = d__1 + pz * pz;
  10461. /*<       IF( RS.LT.1.D-30) GOTO 24 >*/
  10462.     if (rs < 1e-30) {
  10463.         goto L24;
  10464.     }
  10465. /*<       R= SQRT( RS) >*/
  10466.     r = sqrt(rs);
  10467. /*<       PX= PX/ R >*/
  10468.     px /= r;
  10469. /*<       PY= PY/ R >*/
  10470.     py /= r;
  10471. /*<       PZ= PZ/ R >*/
  10472.     pz /= r;
  10473. /*<       CTH= PX* WX+ PY* WY+ PZ* WZ >*/
  10474.     d__1 = px * wx + py * wy;
  10475.     cth = d__1 + pz * wz;
  10476. /*<       STH= SQRT(1.- CTH* CTH) >*/
  10477.     sth = sqrt(1. - cth * cth);
  10478. /*<       QX= PX- WX* CTH >*/
  10479.     qx = px - wx * cth;
  10480. /*<       QY= PY- WY* CTH >*/
  10481.     qy = py - wy * cth;
  10482. /*<       QZ= PZ- WZ* CTH >*/
  10483.     qz = pz - wz * cth;
  10484. /*<       ARG= SQRT( QX* QX+ QY* QY+ QZ* QZ) >*/
  10485.     d__1 = qx * qx + qy * qy;
  10486.     arg = sqrt(d__1 + qz * qz);
  10487. /*<       IF( ARG.LT.1.D-30) GOTO 21 >*/
  10488.     if (arg < 1e-30) {
  10489.         goto L21;
  10490.     }
  10491. /*<       QX= QX/ ARG >*/
  10492.     qx /= arg;
  10493. /*<       QY= QY/ ARG >*/
  10494.     qy /= arg;
  10495. /*<       QZ= QZ/ ARG >*/
  10496.     qz /= arg;
  10497. /*<       GOTO 22 >*/
  10498.     goto L22;
  10499. /*<    21 QX=1. >*/
  10500. L21:
  10501.     qx = 1.;
  10502. /*<       QY=0. >*/
  10503.     qy = 0.;
  10504. /*<       QZ=0. >*/
  10505.     qz = 0.;
  10506. /*<    22 ARG=- TP* R >*/
  10507. L22:
  10508.     arg = -tp * r;
  10509. /*<       TT1= CMPLX( COS( ARG), SIN( ARG)) >*/
  10510.     d__1 = cos(arg);
  10511.     d__2 = sin(arg);
  10512.     z__1.r = d__1, z__1.i = d__2;
  10513.     tt1.r = z__1.r, tt1.i = z__1.i;
  10514. /*<       IF( I.GT. N) GOTO 23 >*/
  10515.     if (i > data_1.n) {
  10516.         goto L23;
  10517.     }
  10518. /*<       TT2= CMPLX(1.D+0,-1.D+0/( R* TP))/ RS >*/
  10519.     d__1 = -1. / (r * tp);
  10520.     z__2.r = 1., z__2.i = d__1;
  10521.     z__1.r = z__2.r / rs, z__1.i = z__2.i / rs;
  10522.     tt2.r = z__1.r, tt2.i = z__1.i;
  10523. /*<       ER= DS* TT1* TT2* CTH >*/
  10524.     z__3.r = ds * tt1.r, z__3.i = ds * tt1.i;
  10525.     z__2.r = z__3.r * tt2.r - z__3.i * tt2.i, z__2.i = z__3.r * tt2.i + 
  10526.         z__3.i * tt2.r;
  10527.     z__1.r = cth * z__2.r, z__1.i = cth * z__2.i;
  10528.     er.r = z__1.r, er.i = z__1.i;
  10529. /*<       ET=.5* DS* TT1*((0.,1.)* TP/ R+ TT2)* STH >*/
  10530.     d__1 = ds * .5;
  10531.     z__3.r = d__1 * tt1.r, z__3.i = d__1 * tt1.i;
  10532.     z__6.r = tp * 0., z__6.i = tp * 1.;
  10533.     z__5.r = z__6.r / r, z__5.i = z__6.i / r;
  10534.     z__4.r = z__5.r + tt2.r, z__4.i = z__5.i + tt2.i;
  10535.     z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i 
  10536.         + z__3.i * z__4.r;
  10537.     z__1.r = sth * z__2.r, z__1.i = sth * z__2.i;
  10538.     et.r = z__1.r, et.i = z__1.i;
  10539. /*<       EZH= ER* CTH- ET* STH >*/
  10540.     z__2.r = cth * er.r, z__2.i = cth * er.i;
  10541.     z__3.r = sth * et.r, z__3.i = sth * et.i;
  10542.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  10543.     ezh.r = z__1.r, ezh.i = z__1.i;
  10544. /*<       ERH= ER* STH+ ET* CTH >*/
  10545.     z__2.r = sth * er.r, z__2.i = sth * er.i;
  10546.     z__3.r = cth * et.r, z__3.i = cth * et.i;
  10547.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  10548.     erh.r = z__1.r, erh.i = z__1.i;
  10549. /*<       CX= EZH* WX+ ERH* QX >*/
  10550.     z__2.r = wx * ezh.r, z__2.i = wx * ezh.i;
  10551.     z__3.r = qx * erh.r, z__3.i = qx * erh.i;
  10552.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  10553.     cx.r = z__1.r, cx.i = z__1.i;
  10554. /*<       CY= EZH* WY+ ERH* QY >*/
  10555.     z__2.r = wy * ezh.r, z__2.i = wy * ezh.i;
  10556.     z__3.r = qy * erh.r, z__3.i = qy * erh.i;
  10557.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  10558.     cy.r = z__1.r, cy.i = z__1.i;
  10559. /*<       CZ= EZH* WZ+ ERH* QZ >*/
  10560.     z__2.r = wz * ezh.r, z__2.i = wz * ezh.i;
  10561.     z__3.r = qz * erh.r, z__3.i = qz * erh.i;
  10562.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  10563.     cz.r = z__1.r, cz.i = z__1.i;
  10564. /*<       E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I)) >*/
  10565.     i__1 = i;
  10566.     i__2 = i - 1;
  10567.     z__4.r = cab[i__2] * cx.r, z__4.i = cab[i__2] * cx.i;
  10568.     i__5 = i - 1;
  10569.     z__5.r = sab[i__5] * cy.r, z__5.i = sab[i__5] * cy.i;
  10570.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  10571.     i__4 = i - 1;
  10572.     z__6.r = angl_1.salp[i__4] * cz.r, z__6.i = angl_1.salp[i__4] * cz.i;
  10573.     z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  10574.     z__1.r = -z__2.r, z__1.i = -z__2.i;
  10575.     e[i__1].r = z__1.r, e[i__1].i = z__1.i;
  10576. /*<       GOTO 24 >*/
  10577.     goto L24;
  10578. /*<    23 PX= WY* QZ- WZ* QY >*/
  10579. L23:
  10580.     px = wy * qz - wz * qy;
  10581. /*<       PY= WZ* QX- WX* QZ >*/
  10582.     py = wz * qx - wx * qz;
  10583. /*<       PZ= WX* QY- WY* QX >*/
  10584.     pz = wx * qy - wy * qx;
  10585. /*<       TT2= DSH* TT1* CMPLX(1./ R, TP)/ R* STH* SALP( II) >*/
  10586.     z__5.r = dsh * tt1.r, z__5.i = dsh * tt1.i;
  10587.     d__1 = 1. / r;
  10588.     z__6.r = d__1, z__6.i = tp;
  10589.     z__4.r = z__5.r * z__6.r - z__5.i * z__6.i, z__4.i = z__5.r * z__6.i 
  10590.         + z__5.i * z__6.r;
  10591.     z__3.r = z__4.r / r, z__3.i = z__4.i / r;
  10592.     z__2.r = sth * z__3.r, z__2.i = sth * z__3.i;
  10593.     i__1 = ii - 1;
  10594.     z__1.r = angl_1.salp[i__1] * z__2.r, z__1.i = angl_1.salp[i__1] * 
  10595.         z__2.i;
  10596.     tt2.r = z__1.r, tt2.i = z__1.i;
  10597. /*<       CX= TT2* PX >*/
  10598.     z__1.r = px * tt2.r, z__1.i = px * tt2.i;
  10599.     cx.r = z__1.r, cx.i = z__1.i;
  10600. /*<       CY= TT2* PY >*/
  10601.     z__1.r = py * tt2.r, z__1.i = py * tt2.i;
  10602.     cy.r = z__1.r, cy.i = z__1.i;
  10603. /*<       CZ= TT2* PZ >*/
  10604.     z__1.r = pz * tt2.r, z__1.i = pz * tt2.i;
  10605.     cz.r = z__1.r, cz.i = z__1.i;
  10606. /*<       E( I2)= CX* T1X( II)+ CY* T1Y( II)+ CZ* T1Z( II) >*/
  10607.     i__1 = i2;
  10608.     i__2 = ii - 1;
  10609.     z__3.r = t1x[i__2] * cx.r, z__3.i = t1x[i__2] * cx.i;
  10610.     i__5 = ii - 1;
  10611.     z__4.r = t1y[i__5] * cy.r, z__4.i = t1y[i__5] * cy.i;
  10612.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  10613.     i__4 = ii - 1;
  10614.     z__5.r = t1z[i__4] * cz.r, z__5.i = t1z[i__4] * cz.i;
  10615.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  10616.     e[i__1].r = z__1.r, e[i__1].i = z__1.i;
  10617. /*<       E( I1)= CX* T2X( II)+ CY* T2Y( II)+ CZ* T2Z( II) >*/
  10618.     i__1 = i1;
  10619.     i__2 = ii - 1;
  10620.     z__3.r = t2x[i__2] * cx.r, z__3.i = t2x[i__2] * cx.i;
  10621.     i__5 = ii - 1;
  10622.     z__4.r = t2y[i__5] * cy.r, z__4.i = t2y[i__5] * cy.i;
  10623.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  10624.     i__4 = ii - 1;
  10625.     z__5.r = t2z[i__4] * cz.r, z__5.i = t2z[i__4] * cz.i;
  10626.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  10627.     e[i__1].r = z__1.r, e[i__1].i = z__1.i;
  10628. /*<    24 CONTINUE >*/
  10629. L24:
  10630.     ;
  10631.     }
  10632. /*<       RETURN >*/
  10633.     return 0;
  10634. /*<       END >*/
  10635. } /* etmns_ */
  10636.  
  10637. #undef sab
  10638. #undef cab
  10639. #undef t2z
  10640. #undef t2y
  10641. #undef t2x
  10642. #undef t1z
  10643. #undef t1y
  10644. #undef t1x
  10645.  
  10646.  
  10647. /* *** */
  10648. /*     DOUBLE PRECISION 6/4/85 */
  10649.  
  10650. /*<    >*/
  10651. /* Subroutine */ int facgf_(a, b, c, d, bx, ip, ix, np, n1, mp, m1, n1c, n2c)
  10652. doublecomplex *a, *b, *c, *d, *bx;
  10653. integer *ip, *ix, *np, *n1, *mp, *m1, *n1c, *n2c;
  10654. {
  10655.     /* System generated locals */
  10656.     integer b_dim1, b_offset, c_dim1, c_offset, d_dim1, d_offset, bx_dim1, 
  10657.         bx_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
  10658.     doublecomplex z__1, z__2;
  10659.     alist al__1;
  10660.  
  10661.     /* Builtin functions */
  10662.     integer f_rew(), s_rsue(), do_uio(), e_rsue(), s_wsue(), e_wsue();
  10663.  
  10664.     /* Local variables */
  10665.     static integer ibfl, i, j, k;
  10666.     extern /* Subroutine */ int facio_(), reblk_(), factr_();
  10667.     static integer icass, nlsys, npsys, ib, ic, ii;
  10668.     extern /* Subroutine */ int lunscr_();
  10669.     static integer nblsys;
  10670.     extern /* Subroutine */ int solves_();
  10671.     static integer nic, npb, npc;
  10672.     static doublecomplex sum;
  10673.     static integer n1cp;
  10674.  
  10675.     /* Fortran I/O blocks */
  10676.     static cilist io___710 = { 0, 0, 0, 0, 0 };
  10677.     static cilist io___713 = { 0, 14, 0, 0, 0 };
  10678.     static cilist io___716 = { 0, 15, 0, 0, 0 };
  10679.     static cilist io___717 = { 0, 12, 0, 0, 0 };
  10680.     static cilist io___719 = { 0, 14, 0, 0, 0 };
  10681.     static cilist io___723 = { 0, 11, 0, 0, 0 };
  10682.     static cilist io___725 = { 0, 11, 0, 0, 0 };
  10683.     static cilist io___726 = { 0, 11, 0, 0, 0 };
  10684.  
  10685.  
  10686. /* *** */
  10687. /*     FACGF COMPUTES AND FACTORS D-C(INV(A)B). */
  10688. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  10689. /*<       COMPLEX  A, B, C, D, BX, SUM >*/
  10690. /*<    >*/
  10691. /*<    >*/
  10692. /*<       IF( N2C.EQ.0) RETURN >*/
  10693.     /* Parameter adjustments */
  10694.     --ix;
  10695.     --ip;
  10696.     bx_dim1 = *n1c;
  10697.     bx_offset = bx_dim1 + 1;
  10698.     bx -= bx_offset;
  10699.     d_dim1 = *n2c;
  10700.     d_offset = d_dim1 + 1;
  10701.     d -= d_offset;
  10702.     c_dim1 = *n1c;
  10703.     c_offset = c_dim1 + 1;
  10704.     c -= c_offset;
  10705.     b_dim1 = *n1c;
  10706.     b_offset = b_dim1 + 1;
  10707.     b -= b_offset;
  10708.     --a;
  10709.  
  10710.     /* Function Body */
  10711.     if (*n2c == 0) {
  10712.     return 0;
  10713.     }
  10714. /*<       IBFL=14 >*/
  10715.     ibfl = 14;
  10716. /*     CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16 */
  10717. /*<       IF( ICASX.LT.3) GOTO 1 >*/
  10718.     if (matpar_1.icasx < 3) {
  10719.     goto L1;
  10720.     }
  10721. /*<       CALL REBLK( B, C, N1C, NPBX, N2C) >*/
  10722.     reblk_(&b[b_offset], &c[c_offset], n1c, &matpar_1.npbx, n2c);
  10723. /*<       IBFL=16 >*/
  10724.     ibfl = 16;
  10725. /*<     1 NPB= NPBL >*/
  10726. L1:
  10727.     npb = matpar_1.npbl;
  10728. /*     COMPUTE INV(A)B AND WRITE ON TAPE14 */
  10729. /*<       IF( ICASX.EQ.2) REWIND 14 >*/
  10730.     if (matpar_1.icasx == 2) {
  10731.     al__1.aerr = 0;
  10732.     al__1.aunit = 14;
  10733.     f_rew(&al__1);
  10734.     }
  10735. /*<       DO 2  IB=1, NBBL >*/
  10736.     i__1 = matpar_1.nbbl;
  10737.     for (ib = 1; ib <= i__1; ++ib) {
  10738. /*<       IF( IB.EQ. NBBL) NPB= NLBL >*/
  10739.     if (ib == matpar_1.nbbl) {
  10740.         npb = matpar_1.nlbl;
  10741.     }
  10742. /*<       IF( ICASX.GT.1) READ( IBFL) (( BX( I, J), I=1, N1C), J=1, NPB) >*/
  10743.     if (matpar_1.icasx > 1) {
  10744.         io___710.ciunit = ibfl;
  10745.         s_rsue(&io___710);
  10746.         i__2 = npb;
  10747.         for (j = 1; j <= i__2; ++j) {
  10748.         i__3 = *n1c;
  10749.         for (i = 1; i <= i__3; ++i) {
  10750.             do_uio(&c__2, (char *)&bx[i + j * bx_dim1], (ftnlen)
  10751.                 sizeof(doublereal));
  10752.         }
  10753.         }
  10754.         e_rsue();
  10755.     }
  10756. /*<       CALL SOLVES( A, IP, BX, N1C, NPB, NP, N1, MP, M1,13,13) >*/
  10757.     solves_(&a[1], &ip[1], &bx[bx_offset], n1c, &npb, np, n1, mp, m1, &
  10758.         c__13, &c__13);
  10759. /*<       IF( ICASX.EQ.2) REWIND 14 >*/
  10760.     if (matpar_1.icasx == 2) {
  10761.         al__1.aerr = 0;
  10762.         al__1.aunit = 14;
  10763.         f_rew(&al__1);
  10764.     }
  10765. /*<       IF( ICASX.GT.1) WRITE( 14) (( BX( I, J), I=1, N1C), J=1, NPB) >*/
  10766.     if (matpar_1.icasx > 1) {
  10767.         s_wsue(&io___713);
  10768.         i__3 = npb;
  10769.         for (j = 1; j <= i__3; ++j) {
  10770.         i__2 = *n1c;
  10771.         for (i = 1; i <= i__2; ++i) {
  10772.             do_uio(&c__2, (char *)&bx[i + j * bx_dim1], (ftnlen)
  10773.                 sizeof(doublereal));
  10774.         }
  10775.         }
  10776.         e_wsue();
  10777.     }
  10778. /*<     2 CONTINUE >*/
  10779. /* L2: */
  10780.     }
  10781. /*<       IF( ICASX.EQ.1) GOTO 3 >*/
  10782.     if (matpar_1.icasx == 1) {
  10783.     goto L3;
  10784.     }
  10785. /*<       REWIND 11 >*/
  10786.     al__1.aerr = 0;
  10787.     al__1.aunit = 11;
  10788.     f_rew(&al__1);
  10789. /*<       REWIND 12 >*/
  10790.     al__1.aerr = 0;
  10791.     al__1.aunit = 12;
  10792.     f_rew(&al__1);
  10793. /*<       REWIND 15 >*/
  10794.     al__1.aerr = 0;
  10795.     al__1.aunit = 15;
  10796.     f_rew(&al__1);
  10797. /*<       REWIND IBFL >*/
  10798.     al__1.aerr = 0;
  10799.     al__1.aunit = ibfl;
  10800.     f_rew(&al__1);
  10801. /*     COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11 */
  10802. /*<     3 NPC= NPBL >*/
  10803. L3:
  10804.     npc = matpar_1.npbl;
  10805. /*<       DO 8  IC=1, NBBL >*/
  10806.     i__1 = matpar_1.nbbl;
  10807.     for (ic = 1; ic <= i__1; ++ic) {
  10808. /*<       IF( IC.EQ. NBBL) NPC= NLBL >*/
  10809.     if (ic == matpar_1.nbbl) {
  10810.         npc = matpar_1.nlbl;
  10811.     }
  10812. /*<       IF( ICASX.EQ.1) GOTO 4 >*/
  10813.     if (matpar_1.icasx == 1) {
  10814.         goto L4;
  10815.     }
  10816. /*<       READ( 15) (( C( I, J), I=1, N1C), J=1, NPC) >*/
  10817.     s_rsue(&io___716);
  10818.     i__2 = npc;
  10819.     for (j = 1; j <= i__2; ++j) {
  10820.         i__3 = *n1c;
  10821.         for (i = 1; i <= i__3; ++i) {
  10822.         do_uio(&c__2, (char *)&c[i + j * c_dim1], (ftnlen)sizeof(
  10823.             doublereal));
  10824.         }
  10825.     }
  10826.     e_rsue();
  10827. /*<       READ( 12) (( D( I, J), I=1, N2C), J=1, NPC) >*/
  10828.     s_rsue(&io___717);
  10829.     i__3 = npc;
  10830.     for (j = 1; j <= i__3; ++j) {
  10831.         i__2 = *n2c;
  10832.         for (i = 1; i <= i__2; ++i) {
  10833.         do_uio(&c__2, (char *)&d[i + j * d_dim1], (ftnlen)sizeof(
  10834.             doublereal));
  10835.         }
  10836.     }
  10837.     e_rsue();
  10838. /*<       REWIND 14 >*/
  10839.     al__1.aerr = 0;
  10840.     al__1.aunit = 14;
  10841.     f_rew(&al__1);
  10842. /*<     4 NPB= NPBL >*/
  10843. L4:
  10844.     npb = matpar_1.npbl;
  10845. /*<       NIC=0 >*/
  10846.     nic = 0;
  10847. /*<       DO 7  IB=1, NBBL >*/
  10848.     i__2 = matpar_1.nbbl;
  10849.     for (ib = 1; ib <= i__2; ++ib) {
  10850. /*<       IF( IB.EQ. NBBL) NPB= NLBL >*/
  10851.         if (ib == matpar_1.nbbl) {
  10852.         npb = matpar_1.nlbl;
  10853.         }
  10854. /*<       IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB) >*/
  10855.         if (matpar_1.icasx > 1) {
  10856.         s_rsue(&io___719);
  10857.         i__3 = npb;
  10858.         for (j = 1; j <= i__3; ++j) {
  10859.             i__4 = *n1c;
  10860.             for (i = 1; i <= i__4; ++i) {
  10861.             do_uio(&c__2, (char *)&b[i + j * b_dim1], (ftnlen)
  10862.                 sizeof(doublereal));
  10863.             }
  10864.         }
  10865.         e_rsue();
  10866.         }
  10867. /*<       DO 6  I=1, NPB >*/
  10868.         i__4 = npb;
  10869.         for (i = 1; i <= i__4; ++i) {
  10870. /*<       II= I+ NIC >*/
  10871.         ii = i + nic;
  10872. /*<       DO 6  J=1, NPC >*/
  10873.         i__3 = npc;
  10874.         for (j = 1; j <= i__3; ++j) {
  10875. /*<       SUM=(0.,0.) >*/
  10876.             sum.r = 0., sum.i = 0.;
  10877. /*<       DO 5  K=1, N1C >*/
  10878.             i__5 = *n1c;
  10879.             for (k = 1; k <= i__5; ++k) {
  10880. /*<     5 SUM= SUM+ B( K, I)* C( K, J) >*/
  10881. /* L5: */
  10882.             i__6 = k + i * b_dim1;
  10883.             i__7 = k + j * c_dim1;
  10884.             z__2.r = b[i__6].r * c[i__7].r - b[i__6].i * c[i__7]
  10885.                 .i, z__2.i = b[i__6].r * c[i__7].i + b[i__6]
  10886.                 .i * c[i__7].r;
  10887.             z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  10888.             sum.r = z__1.r, sum.i = z__1.i;
  10889.             }
  10890. /*<     6 D( II, J)= D( II, J)- SUM >*/
  10891. /* L6: */
  10892.             i__6 = ii + j * d_dim1;
  10893.             i__7 = ii + j * d_dim1;
  10894.             z__1.r = d[i__7].r - sum.r, z__1.i = d[i__7].i - sum.i;
  10895.             d[i__6].r = z__1.r, d[i__6].i = z__1.i;
  10896.         }
  10897.         }
  10898. /*<     7 NIC= NIC+ NPBL >*/
  10899. /* L7: */
  10900.         nic += matpar_1.npbl;
  10901.     }
  10902. /*<       IF( ICASX.GT.1) WRITE( 11) (( D( I, J), I=1, N2C), J=1, NPBL) >*/
  10903.     if (matpar_1.icasx > 1) {
  10904.         s_wsue(&io___723);
  10905.         i__2 = matpar_1.npbl;
  10906.         for (j = 1; j <= i__2; ++j) {
  10907.         i__6 = *n2c;
  10908.         for (i = 1; i <= i__6; ++i) {
  10909.             do_uio(&c__2, (char *)&d[i + j * d_dim1], (ftnlen)sizeof(
  10910.                 doublereal));
  10911.         }
  10912.         }
  10913.         e_wsue();
  10914.     }
  10915. /*<     8 CONTINUE >*/
  10916. /* L8: */
  10917.     }
  10918. /*<       IF( ICASX.EQ.1) GOTO 9 >*/
  10919.     if (matpar_1.icasx == 1) {
  10920.     goto L9;
  10921.     }
  10922. /*<       REWIND 11 >*/
  10923.     al__1.aerr = 0;
  10924.     al__1.aunit = 11;
  10925.     f_rew(&al__1);
  10926. /*<       REWIND 12 >*/
  10927.     al__1.aerr = 0;
  10928.     al__1.aunit = 12;
  10929.     f_rew(&al__1);
  10930. /*<       REWIND 14 >*/
  10931.     al__1.aerr = 0;
  10932.     al__1.aunit = 14;
  10933.     f_rew(&al__1);
  10934. /*<       REWIND 15 >*/
  10935.     al__1.aerr = 0;
  10936.     al__1.aunit = 15;
  10937.     f_rew(&al__1);
  10938. /*     FACTOR D-C(INV(A)B) */
  10939. /*<     9 N1CP= N1C+1 >*/
  10940. L9:
  10941.     n1cp = *n1c + 1;
  10942. /*<       IF( ICASX.GT.1) GOTO 10 >*/
  10943.     if (matpar_1.icasx > 1) {
  10944.     goto L10;
  10945.     }
  10946. /*<       CALL FACTR( N2C, D, IP( N1CP), N2C) >*/
  10947.     factr_(n2c, &d[d_offset], &ip[n1cp], n2c);
  10948. /*<       GOTO 13 >*/
  10949.     goto L13;
  10950. /*<    10 IF( ICASX.EQ.4) GOTO 12 >*/
  10951. L10:
  10952.     if (matpar_1.icasx == 4) {
  10953.     goto L12;
  10954.     }
  10955. /*<       NPB= NPBL >*/
  10956.     npb = matpar_1.npbl;
  10957. /*<       IC=0 >*/
  10958.     ic = 0;
  10959. /*<       DO 11  IB=1, NBBL >*/
  10960.     i__1 = matpar_1.nbbl;
  10961.     for (ib = 1; ib <= i__1; ++ib) {
  10962. /*<       IF( IB.EQ. NBBL) NPB= NLBL >*/
  10963.     if (ib == matpar_1.nbbl) {
  10964.         npb = matpar_1.nlbl;
  10965.     }
  10966. /*<       II= IC+1 >*/
  10967.     ii = ic + 1;
  10968. /*<       IC= IC+ N2C* NPB >*/
  10969.     ic += *n2c * npb;
  10970. /*<    11 READ( 11) ( B( I,1), I= II, IC) >*/
  10971. /* L11: */
  10972.     s_rsue(&io___725);
  10973.     i__6 = ic;
  10974.     for (i = ii; i <= i__6; ++i) {
  10975.         do_uio(&c__2, (char *)&b[i + b_dim1], (ftnlen)sizeof(doublereal));
  10976.  
  10977.     }
  10978.     e_rsue();
  10979.     }
  10980. /*<       REWIND 11 >*/
  10981.     al__1.aerr = 0;
  10982.     al__1.aunit = 11;
  10983.     f_rew(&al__1);
  10984. /*<       CALL FACTR( N2C, B, IP( N1CP), N2C) >*/
  10985.     factr_(n2c, &b[b_offset], &ip[n1cp], n2c);
  10986. /*<       NIC= N2C* N2C >*/
  10987.     nic = *n2c * *n2c;
  10988. /*<       WRITE( 11) ( B( I,1), I=1, NIC) >*/
  10989.     s_wsue(&io___726);
  10990.     i__6 = nic;
  10991.     for (i = 1; i <= i__6; ++i) {
  10992.     do_uio(&c__2, (char *)&b[i + b_dim1], (ftnlen)sizeof(doublereal));
  10993.     }
  10994.     e_wsue();
  10995. /*<       REWIND 11 >*/
  10996.     al__1.aerr = 0;
  10997.     al__1.aunit = 11;
  10998.     f_rew(&al__1);
  10999. /*<       GOTO 13 >*/
  11000.     goto L13;
  11001. /*<    12 NBLSYS= NBLSYM >*/
  11002. L12:
  11003.     nblsys = matpar_1.nblsym;
  11004. /*<       NPSYS= NPSYM >*/
  11005.     npsys = matpar_1.npsym;
  11006. /*<       NLSYS= NLSYM >*/
  11007.     nlsys = matpar_1.nlsym;
  11008. /*<       ICASS= ICASE >*/
  11009.     icass = matpar_1.icase;
  11010. /*<       NBLSYM= NBBL >*/
  11011.     matpar_1.nblsym = matpar_1.nbbl;
  11012. /*<       NPSYM= NPBL >*/
  11013.     matpar_1.npsym = matpar_1.npbl;
  11014. /*<       NLSYM= NLBL >*/
  11015.     matpar_1.nlsym = matpar_1.nlbl;
  11016. /*<       ICASE=3 >*/
  11017.     matpar_1.icase = 3;
  11018. /*<       CALL FACIO( B, N2C,1, IX( N1CP),11,12,16,11) >*/
  11019.     facio_(&b[b_offset], n2c, &c__1, &ix[n1cp], &c__11, &c__12, &c__16, &
  11020.         c__11);
  11021. /*<       CALL LUNSCR( B, N2C,1, IP( N1CP), IX( N1CP),12,11,16) >*/
  11022.     lunscr_(&b[b_offset], n2c, &c__1, &ip[n1cp], &ix[n1cp], &c__12, &c__11, &
  11023.         c__16);
  11024. /*<       NBLSYM= NBLSYS >*/
  11025.     matpar_1.nblsym = nblsys;
  11026. /*<       NPSYM= NPSYS >*/
  11027.     matpar_1.npsym = npsys;
  11028. /*<       NLSYM= NLSYS >*/
  11029.     matpar_1.nlsym = nlsys;
  11030. /*<       ICASE= ICASS >*/
  11031.     matpar_1.icase = icass;
  11032. /*<    13 RETURN >*/
  11033. L13:
  11034.     return 0;
  11035. /*<       END >*/
  11036. } /* facgf_ */
  11037.  
  11038. /* *** */
  11039. /*     DOUBLE PRECISION 6/4/85 */
  11040.  
  11041. /*<       SUBROUTINE FACIO( A, NROW, NOP, IP, IU1, IU2, IU3, IU4) >*/
  11042. /* Subroutine */ int facio_(a, nrow, nop, ip, iu1, iu2, iu3, iu4)
  11043. doublecomplex *a;
  11044. integer *nrow, *nop, *ip, *iu1, *iu2, *iu3, *iu4;
  11045. {
  11046.     /* Format strings */
  11047.     static char fmt_4[] = "(\002 CP TIME TAKEN FOR FACTORIZATION = \002,1p,e\
  11048. 12.5)";
  11049.  
  11050.     /* System generated locals */
  11051.     integer a_dim1, a_offset, i__1, i__2, i__3;
  11052.     alist al__1;
  11053.  
  11054.     /* Builtin functions */
  11055.     integer f_rew(), s_wsfe(), do_fio(), e_wsfe();
  11056.  
  11057.     /* Local variables */
  11058.     static doublereal time;
  11059.     static integer ixbp, i1, i2, i3, i4;
  11060.     static doublereal t1, t2;
  11061.     static integer ifile3, ifile4, ixblk1, ixblk2, ka, kk, it;
  11062.     extern /* Subroutine */ int blckin_(), lfactr_(), blckot_(), secnds_();
  11063.     static integer nbm;
  11064.  
  11065.     /* Fortran I/O blocks */
  11066.     static cilist io___747 = { 0, 6, 0, fmt_4, 0 };
  11067.  
  11068.  
  11069. /* *** */
  11070.  
  11071. /*     FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION */
  11072.  
  11073. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  11074. /*<       COMPLEX  A >*/
  11075. /*<    >*/
  11076. /*<       DIMENSION  A( NROW,1), IP( NROW) >*/
  11077. /*<       IT=2* NPSYM* NROW >*/
  11078.     /* Parameter adjustments */
  11079.     --ip;
  11080.     a_dim1 = *nrow;
  11081.     a_offset = a_dim1 + 1;
  11082.     a -= a_offset;
  11083.  
  11084.     /* Function Body */
  11085.     it = (matpar_1.npsym << 1) * *nrow;
  11086. /*<       NBM= NBLSYM-1 >*/
  11087.     nbm = matpar_1.nblsym - 1;
  11088. /*<       I1=1 >*/
  11089.     i1 = 1;
  11090. /*<       I2= IT >*/
  11091.     i2 = it;
  11092. /*<       I3= I2+1 >*/
  11093.     i3 = i2 + 1;
  11094. /*<       I4=2* IT >*/
  11095.     i4 = it << 1;
  11096. /*<       TIME=0. >*/
  11097.     time = 0.;
  11098. /*<       REWIND IU1 >*/
  11099.     al__1.aerr = 0;
  11100.     al__1.aunit = *iu1;
  11101.     f_rew(&al__1);
  11102. /*<       REWIND IU2 >*/
  11103.     al__1.aerr = 0;
  11104.     al__1.aunit = *iu2;
  11105.     f_rew(&al__1);
  11106. /*<       DO 3  KK=1, NOP >*/
  11107.     i__1 = *nop;
  11108.     for (kk = 1; kk <= i__1; ++kk) {
  11109. /*<       KA=( KK-1)* NROW+1 >*/
  11110.     ka = (kk - 1) * *nrow + 1;
  11111. /*<       IFILE3= IU1 >*/
  11112.     ifile3 = *iu1;
  11113. /*<       IFILE4= IU3 >*/
  11114.     ifile4 = *iu3;
  11115. /*<       DO 2  IXBLK1=1, NBM >*/
  11116.     i__2 = nbm;
  11117.     for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
  11118. /*<       REWIND IU3 >*/
  11119.         al__1.aerr = 0;
  11120.         al__1.aunit = *iu3;
  11121.         f_rew(&al__1);
  11122. /*<       REWIND IU4 >*/
  11123.         al__1.aerr = 0;
  11124.         al__1.aunit = *iu4;
  11125.         f_rew(&al__1);
  11126. /*<       CALL BLCKIN( A, IFILE3, I1, I2,1,17) >*/
  11127.         blckin_(&a[a_offset], &ifile3, &i1, &i2, &c__1, &c__17);
  11128. /*<       IXBP= IXBLK1+1 >*/
  11129.         ixbp = ixblk1 + 1;
  11130. /*<       DO 1  IXBLK2= IXBP, NBLSYM >*/
  11131.         i__3 = matpar_1.nblsym;
  11132.         for (ixblk2 = ixbp; ixblk2 <= i__3; ++ixblk2) {
  11133. /*<       CALL BLCKIN( A, IFILE3, I3, I4,1,18) >*/
  11134.         blckin_(&a[a_offset], &ifile3, &i3, &i4, &c__1, &c__18);
  11135. /*<       CALL SECNDS( T1) >*/
  11136.         secnds_(&t1);
  11137. /*<       CALL LFACTR( A, NROW, IXBLK1, IXBLK2, IP( KA)) >*/
  11138.         lfactr_(&a[a_offset], nrow, &ixblk1, &ixblk2, &ip[ka]);
  11139. /*<       CALL SECNDS( T2) >*/
  11140.         secnds_(&t2);
  11141. /*<       TIME= TIME+ T2- T1 >*/
  11142.         time = time + t2 - t1;
  11143. /*<       IF( IXBLK2.EQ. IXBP) CALL BLCKOT( A, IU2, I1, I2,1,19) >*/
  11144.         if (ixblk2 == ixbp) {
  11145.             blckot_(&a[a_offset], iu2, &i1, &i2, &c__1, &c__19);
  11146.         }
  11147. /*<       IF( IXBLK1.EQ. NBM.AND. IXBLK2.EQ. NBLSYM) IFILE4= IU2 >*/
  11148.         if (ixblk1 == nbm && ixblk2 == matpar_1.nblsym) {
  11149.             ifile4 = *iu2;
  11150.         }
  11151. /*<       CALL BLCKOT( A, IFILE4, I3, I4,1,20) >*/
  11152.         blckot_(&a[a_offset], &ifile4, &i3, &i4, &c__1, &c__20);
  11153. /*<     1 CONTINUE >*/
  11154. /* L1: */
  11155.         }
  11156. /*<       IFILE3= IU3 >*/
  11157.         ifile3 = *iu3;
  11158. /*<       IFILE4= IU4 >*/
  11159.         ifile4 = *iu4;
  11160. /*<       IF(( IXBLK1/2)*2.NE. IXBLK1) GOTO 2 >*/
  11161.         if (ixblk1 / 2 << 1 != ixblk1) {
  11162.         goto L2;
  11163.         }
  11164. /*<       IFILE3= IU4 >*/
  11165.         ifile3 = *iu4;
  11166. /*<       IFILE4= IU3 >*/
  11167.         ifile4 = *iu3;
  11168. /*<     2 CONTINUE >*/
  11169. L2:
  11170.         ;
  11171.     }
  11172. /*<     3 CONTINUE >*/
  11173. /* L3: */
  11174.     }
  11175. /*<       REWIND IU1 >*/
  11176.     al__1.aerr = 0;
  11177.     al__1.aunit = *iu1;
  11178.     f_rew(&al__1);
  11179. /*<       REWIND IU2 >*/
  11180.     al__1.aerr = 0;
  11181.     al__1.aunit = *iu2;
  11182.     f_rew(&al__1);
  11183. /*<       REWIND IU3 >*/
  11184.     al__1.aerr = 0;
  11185.     al__1.aunit = *iu3;
  11186.     f_rew(&al__1);
  11187. /*<       REWIND IU4 >*/
  11188.     al__1.aerr = 0;
  11189.     al__1.aunit = *iu4;
  11190.     f_rew(&al__1);
  11191. /*<       WRITE( 6,4)  TIME >*/
  11192.     s_wsfe(&io___747);
  11193.     do_fio(&c__1, (char *)&time, (ftnlen)sizeof(doublereal));
  11194.     e_wsfe();
  11195.  
  11196. /*<       RETURN >*/
  11197.     return 0;
  11198. /*<     4 FORMAT(' CP TIME TAKEN FOR FACTORIZATION = ',1P,E12.5) >*/
  11199. /*<       END >*/
  11200. } /* facio_ */
  11201.  
  11202. /* *** */
  11203. /*     DOUBLE PRECISION 6/4/85 */
  11204.  
  11205. /*<       SUBROUTINE FACTR( N, A, IP, NDIM) >*/
  11206. /* Subroutine */ int factr_(n, a, ip, ndim)
  11207. integer *n;
  11208. doublecomplex *a;
  11209. integer *ip, *ndim;
  11210. {
  11211.     /* Format strings */
  11212.     static char fmt_10[] = "(\002 \002,\002PIVOT(\002,i3,\002)=\002,1p,e16.8)"
  11213.         ;
  11214.  
  11215.     /* System generated locals */
  11216.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
  11217.     doublecomplex z__1, z__2;
  11218.  
  11219.     /* Builtin functions */
  11220.     void d_cnjg(), z_div();
  11221.     integer s_wsfe(), do_fio(), e_wsfe();
  11222.  
  11223.     /* Local variables */
  11224.     static integer iflg;
  11225.     static doublereal dmax_;
  11226.     static integer i, j, k, r;
  11227.     static doublereal elmag;
  11228.     static integer pj, pr, jp1, rm1, rp1;
  11229.     static doublecomplex arj;
  11230.  
  11231.     /* Fortran I/O blocks */
  11232.     static cilist io___761 = { 0, 6, 0, fmt_10, 0 };
  11233.  
  11234.  
  11235. /* *** */
  11236.  
  11237. /*     SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX 
  11238. */
  11239. /*     AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM 
  11240. */
  11241. /*     PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN */
  11242. /*     NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN RALSTONS 
  11243. */
  11244. /*     TEXT.    (MATRIX TRANSPOSED. */
  11245.  
  11246. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  11247. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  11248. /*<       COMPLEX  A, D, ARJ >*/
  11249. /*<       DIMENSION  A( NDIM, NDIM), IP( NDIM) >*/
  11250. /*<       COMMON  /SCRATM/ D( N2M) >*/
  11251. /*<       INTEGER  R, RM1, RP1, PJ, PR >*/
  11252. /*<       IFLG=0 >*/
  11253.     /* Parameter adjustments */
  11254.     --ip;
  11255.     a_dim1 = *ndim;
  11256.     a_offset = a_dim1 + 1;
  11257.     a -= a_offset;
  11258.  
  11259.     /* Function Body */
  11260.     iflg = 0;
  11261.  
  11262. /*     STEP 1 */
  11263.  
  11264. /*<       DO 9  R=1, N >*/
  11265.     i__1 = *n;
  11266.     for (r = 1; r <= i__1; ++r) {
  11267. /*<       DO 1  K=1, N >*/
  11268.     i__2 = *n;
  11269.     for (k = 1; k <= i__2; ++k) {
  11270. /*<       D( K)= A( R, K) >*/
  11271.         i__3 = k - 1;
  11272.         i__4 = r + k * a_dim1;
  11273.         scratm_1.d[i__3].r = a[i__4].r, scratm_1.d[i__3].i = a[i__4].i;
  11274.  
  11275. /*     STEPS 2 AND 3 */
  11276.  
  11277. /*<     1 CONTINUE >*/
  11278. /* L1: */
  11279.     }
  11280. /*<       RM1= R-1 >*/
  11281.     rm1 = r - 1;
  11282. /*<       IF( RM1.LT.1) GOTO 4 >*/
  11283.     if (rm1 < 1) {
  11284.         goto L4;
  11285.     }
  11286. /*<       DO 3  J=1, RM1 >*/
  11287.     i__2 = rm1;
  11288.     for (j = 1; j <= i__2; ++j) {
  11289. /*<       PJ= IP( J) >*/
  11290.         pj = ip[j];
  11291. /*<       ARJ= D( PJ) >*/
  11292.         i__3 = pj - 1;
  11293.         arj.r = scratm_1.d[i__3].r, arj.i = scratm_1.d[i__3].i;
  11294. /*<       A( R, J)= ARJ >*/
  11295.         i__3 = r + j * a_dim1;
  11296.         a[i__3].r = arj.r, a[i__3].i = arj.i;
  11297. /*<       D( PJ)= D( J) >*/
  11298.         i__3 = pj - 1;
  11299.         i__4 = j - 1;
  11300.         scratm_1.d[i__3].r = scratm_1.d[i__4].r, scratm_1.d[i__3].i = 
  11301.             scratm_1.d[i__4].i;
  11302. /*<       JP1= J+1 >*/
  11303.         jp1 = j + 1;
  11304. /*<       DO 2  I= JP1, N >*/
  11305.         i__3 = *n;
  11306.         for (i = jp1; i <= i__3; ++i) {
  11307. /*<       D( I)= D( I)- A( J, I)* ARJ >*/
  11308.         i__4 = i - 1;
  11309.         i__5 = i - 1;
  11310.         i__6 = j + i * a_dim1;
  11311.         z__2.r = a[i__6].r * arj.r - a[i__6].i * arj.i, z__2.i = a[
  11312.             i__6].r * arj.i + a[i__6].i * arj.r;
  11313.         z__1.r = scratm_1.d[i__5].r - z__2.r, z__1.i = scratm_1.d[
  11314.             i__5].i - z__2.i;
  11315.         scratm_1.d[i__4].r = z__1.r, scratm_1.d[i__4].i = z__1.i;
  11316. /*<     2 CONTINUE >*/
  11317. /* L2: */
  11318.         }
  11319. /*<     3 CONTINUE >*/
  11320. /* L3: */
  11321.     }
  11322.  
  11323. /*     STEP 4 */
  11324.  
  11325. /*<     4 CONTINUE >*/
  11326. L4:
  11327. /*<       DMAX= REAL( D( R)* CONJG( D( R))) >*/
  11328.     i__2 = r - 1;
  11329.     d_cnjg(&z__2, &scratm_1.d[r - 1]);
  11330.     z__1.r = scratm_1.d[i__2].r * z__2.r - scratm_1.d[i__2].i * z__2.i, 
  11331.         z__1.i = scratm_1.d[i__2].r * z__2.i + scratm_1.d[i__2].i * 
  11332.         z__2.r;
  11333.     dmax_ = z__1.r;
  11334. /*<       IP( R)= R >*/
  11335.     ip[r] = r;
  11336. /*<       RP1= R+1 >*/
  11337.     rp1 = r + 1;
  11338. /*<       IF( RP1.GT. N) GOTO 6 >*/
  11339.     if (rp1 > *n) {
  11340.         goto L6;
  11341.     }
  11342. /*<       DO 5  I= RP1, N >*/
  11343.     i__2 = *n;
  11344.     for (i = rp1; i <= i__2; ++i) {
  11345. /*<       ELMAG= REAL( D( I)* CONJG( D( I))) >*/
  11346.         i__3 = i - 1;
  11347.         d_cnjg(&z__2, &scratm_1.d[i - 1]);
  11348.         z__1.r = scratm_1.d[i__3].r * z__2.r - scratm_1.d[i__3].i * 
  11349.             z__2.i, z__1.i = scratm_1.d[i__3].r * z__2.i + scratm_1.d[
  11350.             i__3].i * z__2.r;
  11351.         elmag = z__1.r;
  11352. /*<       IF( ELMAG.LT. DMAX) GOTO 5 >*/
  11353.         if (elmag < dmax_) {
  11354.         goto L5;
  11355.         }
  11356. /*<       DMAX= ELMAG >*/
  11357.         dmax_ = elmag;
  11358. /*<       IP( R)= I >*/
  11359.         ip[r] = i;
  11360. /*<     5 CONTINUE >*/
  11361. L5:
  11362.         ;
  11363.     }
  11364. /*<     6 CONTINUE >*/
  11365. L6:
  11366. /*<       IF( DMAX.LT.1.D-10) IFLG=1 >*/
  11367.     if (dmax_ < 1e-10) {
  11368.         iflg = 1;
  11369.     }
  11370. /*<       PR= IP( R) >*/
  11371.     pr = ip[r];
  11372. /*<       A( R, R)= D( PR) >*/
  11373.     i__2 = r + r * a_dim1;
  11374.     i__3 = pr - 1;
  11375.     a[i__2].r = scratm_1.d[i__3].r, a[i__2].i = scratm_1.d[i__3].i;
  11376.  
  11377. /*     STEP 5 */
  11378.  
  11379. /*<       D( PR)= D( R) >*/
  11380.     i__2 = pr - 1;
  11381.     i__3 = r - 1;
  11382.     scratm_1.d[i__2].r = scratm_1.d[i__3].r, scratm_1.d[i__2].i = 
  11383.         scratm_1.d[i__3].i;
  11384. /*<       IF( RP1.GT. N) GOTO 8 >*/
  11385.     if (rp1 > *n) {
  11386.         goto L8;
  11387.     }
  11388. /*<       ARJ=1./ A( R, R) >*/
  11389.     z_div(&z__1, &c_b48, &a[r + r * a_dim1]);
  11390.     arj.r = z__1.r, arj.i = z__1.i;
  11391. /*<       DO 7  I= RP1, N >*/
  11392.     i__2 = *n;
  11393.     for (i = rp1; i <= i__2; ++i) {
  11394. /*<       A( R, I)= D( I)* ARJ >*/
  11395.         i__3 = r + i * a_dim1;
  11396.         i__4 = i - 1;
  11397.         z__1.r = scratm_1.d[i__4].r * arj.r - scratm_1.d[i__4].i * arj.i, 
  11398.             z__1.i = scratm_1.d[i__4].r * arj.i + scratm_1.d[i__4].i *
  11399.              arj.r;
  11400.         a[i__3].r = z__1.r, a[i__3].i = z__1.i;
  11401. /*<     7 CONTINUE >*/
  11402. /* L7: */
  11403.     }
  11404. /*<     8 CONTINUE >*/
  11405. L8:
  11406. /*<       IF( IFLG.EQ.0) GOTO 9 >*/
  11407.     if (iflg == 0) {
  11408.         goto L9;
  11409.     }
  11410. /*<       WRITE( 6,10)  R, DMAX >*/
  11411.     s_wsfe(&io___761);
  11412.     do_fio(&c__1, (char *)&r, (ftnlen)sizeof(integer));
  11413.     do_fio(&c__1, (char *)&dmax_, (ftnlen)sizeof(doublereal));
  11414.     e_wsfe();
  11415. /*<       IFLG=0 >*/
  11416.     iflg = 0;
  11417. /*<     9 CONTINUE >*/
  11418. L9:
  11419.     ;
  11420.     }
  11421.  
  11422. /*<       RETURN >*/
  11423.     return 0;
  11424. /*<    10 FORMAT(1H ,'PIVOT(',I3,')=',1P,E16.8) >*/
  11425. /*<       END >*/
  11426. } /* factr_ */
  11427.  
  11428. /* *** */
  11429. /*     DOUBLE PRECISION 6/4/85 */
  11430.  
  11431. /*<       SUBROUTINE FACTRS( NP, NROW, A, IP, IX, IU1, IU2, IU3, IU4) >*/
  11432. /* Subroutine */ int factrs_(np, nrow, a, ip, ix, iu1, iu2, iu3, iu4)
  11433. integer *np, *nrow;
  11434. doublecomplex *a;
  11435. integer *ip, *ix, *iu1, *iu2, *iu3, *iu4;
  11436. {
  11437.     /* System generated locals */
  11438.     integer i__1, i__2, i__3, i__4;
  11439.     alist al__1;
  11440.  
  11441.     /* Builtin functions */
  11442.     integer f_rew(), s_wsue(), do_uio(), e_wsue(), s_rsue(), e_rsue();
  11443.  
  11444.     /* Local variables */
  11445.     static integer i, j, k, l;
  11446.     extern /* Subroutine */ int facio_(), factr_();
  11447.     static integer icols, i2, j2, ka, kk;
  11448.     extern /* Subroutine */ int blckin_(), blckot_();
  11449.     static integer icoldx;
  11450.     extern /* Subroutine */ int lunscr_();
  11451.     static integer ir1, ir2, nop, irr1, irr2;
  11452.  
  11453.     /* Fortran I/O blocks */
  11454.     static cilist io___774 = { 0, 0, 0, 0, 0 };
  11455.     static cilist io___776 = { 0, 0, 0, 0, 0 };
  11456.     static cilist io___778 = { 0, 0, 0, 0, 0 };
  11457.     static cilist io___780 = { 0, 0, 0, 0, 0 };
  11458.  
  11459.  
  11460. /* *** */
  11461.  
  11462. /*     FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM */
  11463.  
  11464. /*     MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR */
  11465. /*     MATRICIES.  IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE */
  11466. /*     COMPLETE MATRIX. */
  11467.  
  11468. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  11469. /*<       COMPLEX  A >*/
  11470. /*<    >*/
  11471. /*<       DIMENSION  A(1), IP( NROW), IX( NROW) >*/
  11472. /*<       NOP= NROW/ NP >*/
  11473.     /* Parameter adjustments */
  11474.     --ix;
  11475.     --ip;
  11476.     --a;
  11477.  
  11478.     /* Function Body */
  11479.     nop = *nrow / *np;
  11480. /*<       IF( ICASE.GT.2) GOTO 2 >*/
  11481.     if (matpar_1.icase > 2) {
  11482.     goto L2;
  11483.     }
  11484. /*<       DO 1  KK=1, NOP >*/
  11485.     i__1 = nop;
  11486.     for (kk = 1; kk <= i__1; ++kk) {
  11487. /*<       KA=( KK-1)* NP+1 >*/
  11488.     ka = (kk - 1) * *np + 1;
  11489. /*<     1 CALL FACTR( NP, A( KA), IP( KA), NROW) >*/
  11490. /* L1: */
  11491.     factr_(np, &a[ka], &ip[ka], nrow);
  11492.     }
  11493. /*<       RETURN >*/
  11494.     return 0;
  11495.  
  11496. /*     FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY */
  11497. /*     EXISTS. */
  11498.  
  11499. /*<     2 IF( ICASE.GT.3) GOTO 3 >*/
  11500. L2:
  11501.     if (matpar_1.icase > 3) {
  11502.     goto L3;
  11503.     }
  11504. /*<       CALL FACIO( A, NROW, NOP, IX, IU1, IU2, IU3, IU4) >*/
  11505.     facio_(&a[1], nrow, &nop, &ix[1], iu1, iu2, iu3, iu4);
  11506. /*<       CALL LUNSCR( A, NROW, NOP, IP, IX, IU2, IU3, IU4) >*/
  11507.     lunscr_(&a[1], nrow, &nop, &ip[1], &ix[1], iu2, iu3, iu4);
  11508.  
  11509. /*     REWRITE THE MATRICES BY COLUMNS ON TAPE 13 */
  11510.  
  11511. /*<       RETURN >*/
  11512.     return 0;
  11513. /*<     3 I2=2* NPBLK* NROW >*/
  11514. L3:
  11515.     i2 = (matpar_1.npblk << 1) * *nrow;
  11516. /*<       REWIND IU2 >*/
  11517.     al__1.aerr = 0;
  11518.     al__1.aunit = *iu2;
  11519.     f_rew(&al__1);
  11520. /*<       DO 5  K=1, NOP >*/
  11521.     i__1 = nop;
  11522.     for (k = 1; k <= i__1; ++k) {
  11523. /*<       REWIND IU1 >*/
  11524.     al__1.aerr = 0;
  11525.     al__1.aunit = *iu1;
  11526.     f_rew(&al__1);
  11527. /*<       ICOLS= NPBLK >*/
  11528.     icols = matpar_1.npblk;
  11529. /*<       IR2= K* NP >*/
  11530.     ir2 = k * *np;
  11531. /*<       IR1= IR2- NP+1 >*/
  11532.     ir1 = ir2 - *np + 1;
  11533. /*<       DO 5  L=1, NBLOKS >*/
  11534.     i__2 = matpar_1.nbloks;
  11535.     for (l = 1; l <= i__2; ++l) {
  11536. /*<       IF( NBLOKS.EQ.1.AND. K.GT.1) GOTO 4 >*/
  11537.         if (matpar_1.nbloks == 1 && k > 1) {
  11538.         goto L4;
  11539.         }
  11540. /*<       CALL BLCKIN( A, IU1,1, I2,1,602) >*/
  11541.         blckin_(&a[1], iu1, &c__1, &i2, &c__1, &c__602);
  11542. /*<       IF( L.EQ. NBLOKS) ICOLS= NLAST >*/
  11543.         if (l == matpar_1.nbloks) {
  11544.         icols = matpar_1.nlast;
  11545.         }
  11546. /*<     4 IRR1= IR1 >*/
  11547. L4:
  11548.         irr1 = ir1;
  11549. /*<       IRR2= IR2 >*/
  11550.         irr2 = ir2;
  11551. /*<       DO 5  ICOLDX=1, ICOLS >*/
  11552.         i__3 = icols;
  11553.         for (icoldx = 1; icoldx <= i__3; ++icoldx) {
  11554. /*<       WRITE( IU2) ( A( I), I= IRR1, IRR2) >*/
  11555.         io___774.ciunit = *iu2;
  11556.         s_wsue(&io___774);
  11557.         i__4 = irr2;
  11558.         for (i = irr1; i <= i__4; ++i) {
  11559.             do_uio(&c__2, (char *)&a[i], (ftnlen)sizeof(doublereal));
  11560.         }
  11561.         e_wsue();
  11562. /*<       IRR1= IRR1+ NROW >*/
  11563.         irr1 += *nrow;
  11564. /*<       IRR2= IRR2+ NROW >*/
  11565.         irr2 += *nrow;
  11566. /*<     5 CONTINUE >*/
  11567. /* L5: */
  11568.         }
  11569.     }
  11570.     }
  11571. /*<       REWIND IU1 >*/
  11572.     al__1.aerr = 0;
  11573.     al__1.aunit = *iu1;
  11574.     f_rew(&al__1);
  11575. /*<       REWIND IU2 >*/
  11576.     al__1.aerr = 0;
  11577.     al__1.aunit = *iu2;
  11578.     f_rew(&al__1);
  11579. /*<       IF( ICASE.EQ.5) GOTO 8 >*/
  11580.     if (matpar_1.icase == 5) {
  11581.     goto L8;
  11582.     }
  11583. /*<       REWIND IU3 >*/
  11584.     al__1.aerr = 0;
  11585.     al__1.aunit = *iu3;
  11586.     f_rew(&al__1);
  11587. /*<       IRR1= NP* NP >*/
  11588.     irr1 = *np * *np;
  11589. /*<       DO 7  KK=1, NOP >*/
  11590.     i__3 = nop;
  11591.     for (kk = 1; kk <= i__3; ++kk) {
  11592. /*<       IR1=1- NP >*/
  11593.     ir1 = 1 - *np;
  11594. /*<       IR2=0 >*/
  11595.     ir2 = 0;
  11596. /*<       DO 6  I=1, NP >*/
  11597.     i__2 = *np;
  11598.     for (i = 1; i <= i__2; ++i) {
  11599. /*<       IR1= IR1+ NP >*/
  11600.         ir1 += *np;
  11601. /*<       IR2= IR2+ NP >*/
  11602.         ir2 += *np;
  11603. /*<     6 READ( IU2) ( A( J), J= IR1, IR2) >*/
  11604. /* L6: */
  11605.         io___776.ciunit = *iu2;
  11606.         s_rsue(&io___776);
  11607.         i__1 = ir2;
  11608.         for (j = ir1; j <= i__1; ++j) {
  11609.         do_uio(&c__2, (char *)&a[j], (ftnlen)sizeof(doublereal));
  11610.         }
  11611.         e_rsue();
  11612.     }
  11613. /*<       KA=( KK-1)* NP+1 >*/
  11614.     ka = (kk - 1) * *np + 1;
  11615. /*<       CALL FACTR( NP, A, IP( KA), NP) >*/
  11616.     factr_(np, &a[1], &ip[ka], np);
  11617. /*<       WRITE( IU3) ( A( I), I=1, IRR1) >*/
  11618.     io___778.ciunit = *iu3;
  11619.     s_wsue(&io___778);
  11620.     i__1 = irr1;
  11621.     for (i = 1; i <= i__1; ++i) {
  11622.         do_uio(&c__2, (char *)&a[i], (ftnlen)sizeof(doublereal));
  11623.     }
  11624.     e_wsue();
  11625. /*<     7 CONTINUE >*/
  11626. /* L7: */
  11627.     }
  11628. /*<       REWIND IU2 >*/
  11629.     al__1.aerr = 0;
  11630.     al__1.aunit = *iu2;
  11631.     f_rew(&al__1);
  11632. /*<       REWIND IU3 >*/
  11633.     al__1.aerr = 0;
  11634.     al__1.aunit = *iu3;
  11635.     f_rew(&al__1);
  11636. /*<       RETURN >*/
  11637.     return 0;
  11638. /*<     8 I2=2* NPSYM* NP >*/
  11639. L8:
  11640.     i2 = (matpar_1.npsym << 1) * *np;
  11641. /*<       DO 10  KK=1, NOP >*/
  11642.     i__3 = nop;
  11643.     for (kk = 1; kk <= i__3; ++kk) {
  11644. /*<       J2= NPSYM >*/
  11645.     j2 = matpar_1.npsym;
  11646. /*<       DO 10  L=1, NBLSYM >*/
  11647.     i__1 = matpar_1.nblsym;
  11648.     for (l = 1; l <= i__1; ++l) {
  11649. /*<       IF( L.EQ. NBLSYM) J2= NLSYM >*/
  11650.         if (l == matpar_1.nblsym) {
  11651.         j2 = matpar_1.nlsym;
  11652.         }
  11653. /*<       IR1=1- NP >*/
  11654.         ir1 = 1 - *np;
  11655. /*<       IR2=0 >*/
  11656.         ir2 = 0;
  11657. /*<       DO 9  J=1, J2 >*/
  11658.         i__2 = j2;
  11659.         for (j = 1; j <= i__2; ++j) {
  11660. /*<       IR1= IR1+ NP >*/
  11661.         ir1 += *np;
  11662. /*<       IR2= IR2+ NP >*/
  11663.         ir2 += *np;
  11664. /*<     9 READ( IU2) ( A( I), I= IR1, IR2) >*/
  11665. /* L9: */
  11666.         io___780.ciunit = *iu2;
  11667.         s_rsue(&io___780);
  11668.         i__4 = ir2;
  11669.         for (i = ir1; i <= i__4; ++i) {
  11670.             do_uio(&c__2, (char *)&a[i], (ftnlen)sizeof(doublereal));
  11671.         }
  11672.         e_rsue();
  11673.         }
  11674. /*<    10 CALL BLCKOT( A, IU1,1, I2,1,193) >*/
  11675. /* L10: */
  11676.         blckot_(&a[1], iu1, &c__1, &i2, &c__1, &c__193);
  11677.     }
  11678.     }
  11679. /*<       REWIND IU1 >*/
  11680.     al__1.aerr = 0;
  11681.     al__1.aunit = *iu1;
  11682.     f_rew(&al__1);
  11683. /*<       CALL FACIO( A, NP, NOP, IX, IU1, IU2, IU3, IU4) >*/
  11684.     facio_(&a[1], np, &nop, &ix[1], iu1, iu2, iu3, iu4);
  11685. /*<       CALL LUNSCR( A, NP, NOP, IP, IX, IU2, IU3, IU4) >*/
  11686.     lunscr_(&a[1], np, &nop, &ip[1], &ix[1], iu2, iu3, iu4);
  11687. /*<       RETURN >*/
  11688.     return 0;
  11689. /*<       END >*/
  11690. } /* factrs_ */
  11691.  
  11692. /* *** */
  11693. /*     DOUBLE PRECISION 6/4/85 */
  11694.  
  11695. /* jcb      COMPLEX FUNCTION FBAR( P) */
  11696. /*<       FUNCTION FBAR( P) >*/
  11697. /* Double Complex */ int fbar_( ret_val, p)
  11698. doublecomplex * ret_val;
  11699. doublecomplex *p;
  11700. {
  11701.     /* Initialized data */
  11702.  
  11703.     static doublereal tosp = 1.128379167;
  11704.     static doublereal accs = 1e-12;
  11705.     static doublereal sp = 1.772453851;
  11706.     static struct {
  11707.     doublereal e_1[3];
  11708.     } equiv_0 = { 0., 1., 0. };
  11709.  
  11710.  
  11711.     /* System generated locals */
  11712.     doublereal d__1;
  11713.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
  11714.  
  11715.     /* Builtin functions */
  11716.     void z_sqrt();
  11717.     double z_abs();
  11718.     void d_cnjg(), z_exp(), z_div();
  11719.  
  11720.     /* Local variables */
  11721.     static doublecomplex term;
  11722.     static integer i;
  11723.     static doublecomplex z;
  11724.     static integer minus;
  11725. #define fj ((doublecomplex *)&equiv_0)
  11726.     static doublecomplex zs;
  11727. #define fjx ((doublereal *)&equiv_0)
  11728.     static doublereal sms, tms;
  11729.     static doublecomplex sum, pow;
  11730.  
  11731. /* *** */
  11732.  
  11733. /*     FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P */
  11734.  
  11735.  
  11736. /* jcb      IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
  11737. /*<       COMPLEX  Z, ZS, SUM, POW, TERM, P, FJ, FBAR >*/
  11738. /*<       DIMENSION  FJX(2) >*/
  11739. /*<       EQUIVALENCE(FJ,FJX) >*/
  11740. /*<    >*/
  11741. /*<       Z= FJ* SQRT( P) >*/
  11742.     z_sqrt(&z__2, p);
  11743.     z__1.r = fj->r * z__2.r - fj->i * z__2.i, z__1.i = fj->r * z__2.i + fj->i 
  11744.         * z__2.r;
  11745.     z.r = z__1.r, z.i = z__1.i;
  11746.  
  11747. /*     SERIES EXPANSION */
  11748.  
  11749. /*<       IF( ABS( Z).GT.3.) GOTO 3 >*/
  11750.     if (z_abs(&z) > 3.) {
  11751.     goto L3;
  11752.     }
  11753. /*<       ZS= Z* Z >*/
  11754.     z__1.r = z.r * z.r - z.i * z.i, z__1.i = z.r * z.i + z.i * z.r;
  11755.     zs.r = z__1.r, zs.i = z__1.i;
  11756. /*<       SUM= Z >*/
  11757.     sum.r = z.r, sum.i = z.i;
  11758. /*<       POW= Z >*/
  11759.     pow.r = z.r, pow.i = z.i;
  11760. /*<       DO 1  I=1,100 >*/
  11761.     for (i = 1; i <= 100; ++i) {
  11762. /*<       POW=- POW* ZS/ DFLOAT( I) >*/
  11763.     z__3.r = -pow.r, z__3.i = -pow.i;
  11764.     z__2.r = z__3.r * zs.r - z__3.i * zs.i, z__2.i = z__3.r * zs.i + 
  11765.         z__3.i * zs.r;
  11766.     d__1 = (doublereal) i;
  11767.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  11768.     pow.r = z__1.r, pow.i = z__1.i;
  11769. /*<       TERM= POW/(2.* I+1.) >*/
  11770.     d__1 = i * 2. + 1.;
  11771.     z__1.r = pow.r / d__1, z__1.i = pow.i / d__1;
  11772.     term.r = z__1.r, term.i = z__1.i;
  11773. /*<       SUM= SUM+ TERM >*/
  11774.     z__1.r = sum.r + term.r, z__1.i = sum.i + term.i;
  11775.     sum.r = z__1.r, sum.i = z__1.i;
  11776. /*<       TMS= REAL( TERM* CONJG( TERM)) >*/
  11777.     d_cnjg(&z__2, &term);
  11778.     z__1.r = term.r * z__2.r - term.i * z__2.i, z__1.i = term.r * z__2.i 
  11779.         + term.i * z__2.r;
  11780.     tms = z__1.r;
  11781. /*<       SMS= REAL( SUM* CONJG( SUM)) >*/
  11782.     d_cnjg(&z__2, &sum);
  11783.     z__1.r = sum.r * z__2.r - sum.i * z__2.i, z__1.i = sum.r * z__2.i + 
  11784.         sum.i * z__2.r;
  11785.     sms = z__1.r;
  11786. /*<       IF( TMS/ SMS.LT. ACCS) GOTO 2 >*/
  11787.     if (tms / sms < accs) {
  11788.         goto L2;
  11789.     }
  11790. /*<     1 CONTINUE >*/
  11791. /* L1: */
  11792.     }
  11793. /*<     2 FBAR=1.-(1.- SUM* TOSP)* Z* EXP( ZS)* SP >*/
  11794. L2:
  11795.     z__6.r = tosp * sum.r, z__6.i = tosp * sum.i;
  11796.     z__5.r = 1. - z__6.r, z__5.i = -z__6.i;
  11797.     z__4.r = z__5.r * z.r - z__5.i * z.i, z__4.i = z__5.r * z.i + z__5.i * 
  11798.         z.r;
  11799.     z_exp(&z__7, &zs);
  11800.     z__3.r = z__4.r * z__7.r - z__4.i * z__7.i, z__3.i = z__4.r * z__7.i + 
  11801.         z__4.i * z__7.r;
  11802.     z__2.r = sp * z__3.r, z__2.i = sp * z__3.i;
  11803.     z__1.r = 1. - z__2.r, z__1.i = -z__2.i;
  11804.      ret_val->r = z__1.r,  ret_val->i = z__1.i;
  11805.  
  11806. /*     ASYMPTOTIC EXPANSION */
  11807.  
  11808. /*<       RETURN >*/
  11809.     return ;
  11810. /*<     3 IF( REAL( Z).GE.0.) GOTO 4 >*/
  11811. L3:
  11812.     if (z.r >= 0.) {
  11813.     goto L4;
  11814.     }
  11815. /*<       MINUS=1 >*/
  11816.     minus = 1;
  11817. /*<       Z=- Z >*/
  11818.     z__1.r = -z.r, z__1.i = -z.i;
  11819.     z.r = z__1.r, z.i = z__1.i;
  11820. /*<       GOTO 5 >*/
  11821.     goto L5;
  11822. /*<     4 MINUS=0 >*/
  11823. L4:
  11824.     minus = 0;
  11825. /*<     5 ZS=.5/( Z* Z) >*/
  11826. L5:
  11827.     z__2.r = z.r * z.r - z.i * z.i, z__2.i = z.r * z.i + z.i * z.r;
  11828.     z_div(&z__1, &c_b1190, &z__2);
  11829.     zs.r = z__1.r, zs.i = z__1.i;
  11830. /*<       SUM=(0.,0.) >*/
  11831.     sum.r = 0., sum.i = 0.;
  11832. /*<       TERM=(1.,0.) >*/
  11833.     term.r = 1., term.i = 0.;
  11834. /*<       DO 6  I=1,6 >*/
  11835.     for (i = 1; i <= 6; ++i) {
  11836. /*<       TERM=- TERM*(2.* I-1.)* ZS >*/
  11837.     z__3.r = -term.r, z__3.i = -term.i;
  11838.     d__1 = i * 2. - 1.;
  11839.     z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
  11840.     z__1.r = z__2.r * zs.r - z__2.i * zs.i, z__1.i = z__2.r * zs.i + 
  11841.         z__2.i * zs.r;
  11842.     term.r = z__1.r, term.i = z__1.i;
  11843. /*<     6 SUM= SUM+ TERM >*/
  11844. /* L6: */
  11845.     z__1.r = sum.r + term.r, z__1.i = sum.i + term.i;
  11846.     sum.r = z__1.r, sum.i = z__1.i;
  11847.     }
  11848. /*<       IF( MINUS.EQ.1) SUM= SUM-2.* SP* Z* EXP( Z* Z) >*/
  11849.     if (minus == 1) {
  11850.     d__1 = sp * 2.;
  11851.     z__3.r = d__1 * z.r, z__3.i = d__1 * z.i;
  11852.     z__5.r = z.r * z.r - z.i * z.i, z__5.i = z.r * z.i + z.i * z.r;
  11853.     z_exp(&z__4, &z__5);
  11854.     z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i 
  11855.         + z__3.i * z__4.r;
  11856.     z__1.r = sum.r - z__2.r, z__1.i = sum.i - z__2.i;
  11857.     sum.r = z__1.r, sum.i = z__1.i;
  11858.     }
  11859. /*<       FBAR=- SUM >*/
  11860.     z__1.r = -sum.r, z__1.i = -sum.i;
  11861.      ret_val->r = z__1.r,  ret_val->i = z__1.i;
  11862. /*<       RETURN >*/
  11863.     return ;
  11864. /*<       END >*/
  11865. } /* fbar_ */
  11866.  
  11867. #undef fjx
  11868. #undef fj
  11869.  
  11870.  
  11871. /* *** */
  11872. /*     DOUBLE PRECISION 6/4/85 */
  11873.  
  11874. /*<       SUBROUTINE FBLOCK( NROW, NCOL, IMAX, IRNGF, IPSYM) >*/
  11875. /* Subroutine */ int fblock_(nrow, ncol, imax, irngf, ipsym)
  11876. integer *nrow, *ncol, *imax, *irngf, *ipsym;
  11877. {
  11878.     /* Format strings */
  11879.     static char fmt_14[] = "(//\002 MATRIX FILE STORAGE -  NO. BLOCKS=\002,i\
  11880. 5,\002 COLUMNS PE\002,\002R BLOCK=\002,i5,\002 COLUMNS IN LAST BLOCK=\002,i5)"
  11881.         ;
  11882.     static char fmt_15[] = "(\002 SUBMATRICIES FIT IN CORE\002)";
  11883.     static char fmt_16[] = "(\002 SUBMATRIX PARTITIONING -  NO. BLOCKS=\002,\
  11884. i5,\002 COLUMNS P\002,\002ER BLOCK=\002,i5,\002 COLUMNS IN LAST BLOCK=\002,i\
  11885. 5)";
  11886.     static char fmt_17[] = "(\002 ERROR - INSUFFICIENT STORAGE FOR MATRIX\
  11887. \002,2i5)";
  11888.     static char fmt_18[] = "(\002 SYMMETRY ERROR - NROW,NCOL=\002,2i5)";
  11889.  
  11890.     /* System generated locals */
  11891.     integer i__1, i__2, i__3, i__4;
  11892.     doublereal d__1, d__2;
  11893.     doublecomplex z__1;
  11894.  
  11895.     /* Builtin functions */
  11896.     integer s_wsfe(), do_fio(), e_wsfe();
  11897.     double cos(), sin();
  11898.     /* Subroutine */ int s_stop();
  11899.  
  11900.     /* Local variables */
  11901.     static doublereal phaz;
  11902.     static integer i, j, k;
  11903.     static doublecomplex deter;
  11904.     static integer ka, kk;
  11905.     static doublereal arg;
  11906.     static integer nop, imx1;
  11907.  
  11908.     /* Fortran I/O blocks */
  11909.     static cilist io___796 = { 0, 6, 0, fmt_14, 0 };
  11910.     static cilist io___797 = { 0, 6, 0, fmt_14, 0 };
  11911.     static cilist io___798 = { 0, 6, 0, fmt_15, 0 };
  11912.     static cilist io___799 = { 0, 6, 0, fmt_16, 0 };
  11913.     static cilist io___809 = { 0, 6, 0, fmt_17, 0 };
  11914.     static cilist io___810 = { 0, 6, 0, fmt_18, 0 };
  11915.  
  11916.  
  11917. /* *** */
  11918. /*     FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY */
  11919. /*     MATRIX (A) */
  11920. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  11921. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  11922. /*<       COMPLEX  SSX, DETER >*/
  11923. /*<    >*/
  11924. /*<       COMMON  /SMAT/ SSX(16,16) >*/
  11925. /*<       IMX1= IMAX- IRNGF >*/
  11926.     imx1 = *imax - *irngf;
  11927. /*<       IF( NROW* NCOL.GT. IMX1) GOTO 2 >*/
  11928.     if (*nrow * *ncol > imx1) {
  11929.     goto L2;
  11930.     }
  11931. /*<       NBLOKS=1 >*/
  11932.     matpar_1.nbloks = 1;
  11933. /*<       NPBLK= NROW >*/
  11934.     matpar_1.npblk = *nrow;
  11935. /*<       NLAST= NROW >*/
  11936.     matpar_1.nlast = *nrow;
  11937. /*<       IMAT= NROW* NCOL >*/
  11938.     matpar_1.imat = *nrow * *ncol;
  11939. /*<       IF( NROW.NE. NCOL) GOTO 1 >*/
  11940.     if (*nrow != *ncol) {
  11941.     goto L1;
  11942.     }
  11943. /*<       ICASE=1 >*/
  11944.     matpar_1.icase = 1;
  11945. /*<       RETURN >*/
  11946.     return 0;
  11947. /*<     1 ICASE=2 >*/
  11948. L1:
  11949.     matpar_1.icase = 2;
  11950. /*<       GOTO 5 >*/
  11951.     goto L5;
  11952. /*<     2 IF( NROW.NE. NCOL) GOTO 3 >*/
  11953. L2:
  11954.     if (*nrow != *ncol) {
  11955.     goto L3;
  11956.     }
  11957. /*<       ICASE=3 >*/
  11958.     matpar_1.icase = 3;
  11959. /*<       NPBLK= IMAX/(2* NCOL) >*/
  11960.     matpar_1.npblk = *imax / (*ncol << 1);
  11961. /*<       NPSYM= IMX1/ NCOL >*/
  11962.     matpar_1.npsym = imx1 / *ncol;
  11963. /*<       IF( NPSYM.LT. NPBLK) NPBLK= NPSYM >*/
  11964.     if (matpar_1.npsym < matpar_1.npblk) {
  11965.     matpar_1.npblk = matpar_1.npsym;
  11966.     }
  11967. /*<       IF( NPBLK.LT.1) GOTO 12 >*/
  11968.     if (matpar_1.npblk < 1) {
  11969.     goto L12;
  11970.     }
  11971. /*<       NBLOKS=( NROW-1)/ NPBLK >*/
  11972.     matpar_1.nbloks = (*nrow - 1) / matpar_1.npblk;
  11973. /*<       NLAST= NROW- NBLOKS* NPBLK >*/
  11974.     matpar_1.nlast = *nrow - matpar_1.nbloks * matpar_1.npblk;
  11975. /*<       NBLOKS= NBLOKS+1 >*/
  11976.     ++matpar_1.nbloks;
  11977. /*<       NBLSYM= NBLOKS >*/
  11978.     matpar_1.nblsym = matpar_1.nbloks;
  11979. /*<       NPSYM= NPBLK >*/
  11980.     matpar_1.npsym = matpar_1.npblk;
  11981. /*<       NLSYM= NLAST >*/
  11982.     matpar_1.nlsym = matpar_1.nlast;
  11983. /*<       IMAT= NPBLK* NCOL >*/
  11984.     matpar_1.imat = matpar_1.npblk * *ncol;
  11985. /*<       WRITE( 6,14)  NBLOKS, NPBLK, NLAST >*/
  11986.     s_wsfe(&io___796);
  11987.     do_fio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
  11988.     do_fio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
  11989.     do_fio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
  11990.     e_wsfe();
  11991. /*<       GOTO 11 >*/
  11992.     goto L11;
  11993. /*<     3 NPBLK= IMAX/ NCOL >*/
  11994. L3:
  11995.     matpar_1.npblk = *imax / *ncol;
  11996. /*<       IF( NPBLK.LT.1) GOTO 12 >*/
  11997.     if (matpar_1.npblk < 1) {
  11998.     goto L12;
  11999.     }
  12000. /*<       IF( NPBLK.GT. NROW) NPBLK= NROW >*/
  12001.     if (matpar_1.npblk > *nrow) {
  12002.     matpar_1.npblk = *nrow;
  12003.     }
  12004. /*<       NBLOKS=( NROW-1)/ NPBLK >*/
  12005.     matpar_1.nbloks = (*nrow - 1) / matpar_1.npblk;
  12006. /*<       NLAST= NROW- NBLOKS* NPBLK >*/
  12007.     matpar_1.nlast = *nrow - matpar_1.nbloks * matpar_1.npblk;
  12008. /*<       NBLOKS= NBLOKS+1 >*/
  12009.     ++matpar_1.nbloks;
  12010. /*<       WRITE( 6,14)  NBLOKS, NPBLK, NLAST >*/
  12011.     s_wsfe(&io___797);
  12012.     do_fio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
  12013.     do_fio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
  12014.     do_fio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
  12015.     e_wsfe();
  12016. /*<       IF( NROW* NROW.GT. IMX1) GOTO 4 >*/
  12017.     if (*nrow * *nrow > imx1) {
  12018.     goto L4;
  12019.     }
  12020. /*<       ICASE=4 >*/
  12021.     matpar_1.icase = 4;
  12022. /*<       NBLSYM=1 >*/
  12023.     matpar_1.nblsym = 1;
  12024. /*<       NPSYM= NROW >*/
  12025.     matpar_1.npsym = *nrow;
  12026. /*<       NLSYM= NROW >*/
  12027.     matpar_1.nlsym = *nrow;
  12028. /*<       IMAT= NROW* NROW >*/
  12029.     matpar_1.imat = *nrow * *nrow;
  12030. /*<       WRITE( 6,15)  >*/
  12031.     s_wsfe(&io___798);
  12032.     e_wsfe();
  12033. /*<       GOTO 5 >*/
  12034.     goto L5;
  12035. /*<     4 ICASE=5 >*/
  12036. L4:
  12037.     matpar_1.icase = 5;
  12038. /*<       NPSYM= IMAX/(2* NROW) >*/
  12039.     matpar_1.npsym = *imax / (*nrow << 1);
  12040. /*<       NBLSYM= IMX1/ NROW >*/
  12041.     matpar_1.nblsym = imx1 / *nrow;
  12042. /*<       IF( NBLSYM.LT. NPSYM) NPSYM= NBLSYM >*/
  12043.     if (matpar_1.nblsym < matpar_1.npsym) {
  12044.     matpar_1.npsym = matpar_1.nblsym;
  12045.     }
  12046. /*<       IF( NPSYM.LT.1) GOTO 12 >*/
  12047.     if (matpar_1.npsym < 1) {
  12048.     goto L12;
  12049.     }
  12050. /*<       NBLSYM=( NROW-1)/ NPSYM >*/
  12051.     matpar_1.nblsym = (*nrow - 1) / matpar_1.npsym;
  12052. /*<       NLSYM= NROW- NBLSYM* NPSYM >*/
  12053.     matpar_1.nlsym = *nrow - matpar_1.nblsym * matpar_1.npsym;
  12054. /*<       NBLSYM= NBLSYM+1 >*/
  12055.     ++matpar_1.nblsym;
  12056. /*<       WRITE( 6,16)  NBLSYM, NPSYM, NLSYM >*/
  12057.     s_wsfe(&io___799);
  12058.     do_fio(&c__1, (char *)&matpar_1.nblsym, (ftnlen)sizeof(integer));
  12059.     do_fio(&c__1, (char *)&matpar_1.npsym, (ftnlen)sizeof(integer));
  12060.     do_fio(&c__1, (char *)&matpar_1.nlsym, (ftnlen)sizeof(integer));
  12061.     e_wsfe();
  12062. /*<       IMAT= NPSYM* NROW >*/
  12063.     matpar_1.imat = matpar_1.npsym * *nrow;
  12064. /*<     5 NOP= NCOL/ NROW >*/
  12065. L5:
  12066.     nop = *ncol / *nrow;
  12067. /*<       IF( NOP* NROW.NE. NCOL) GOTO 13 >*/
  12068.     if (nop * *nrow != *ncol) {
  12069.     goto L13;
  12070.     }
  12071.  
  12072. /*     SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY. */
  12073.  
  12074. /*<       IF( IPSYM.GT.0) GOTO 7 >*/
  12075.     if (*ipsym > 0) {
  12076.     goto L7;
  12077.     }
  12078. /*<       PHAZ=6.2831853072D+0/ NOP >*/
  12079.     phaz = 6.2831853072 / nop;
  12080. /*<       DO 6  I=2, NOP >*/
  12081.     i__1 = nop;
  12082.     for (i = 2; i <= i__1; ++i) {
  12083. /*<       DO 6  J= I, NOP >*/
  12084.     i__2 = nop;
  12085.     for (j = i; j <= i__2; ++j) {
  12086. /*<       ARG= PHAZ* DFLOAT( I-1)* DFLOAT( J-1) >*/
  12087.         d__1 = phaz * (doublereal) (i - 1);
  12088.         arg = d__1 * (doublereal) (j - 1);
  12089. /*<       SSX( I, J)= CMPLX( COS( ARG), SIN( ARG)) >*/
  12090.         i__3 = i + (j << 4) - 17;
  12091.         d__1 = cos(arg);
  12092.         d__2 = sin(arg);
  12093.         z__1.r = d__1, z__1.i = d__2;
  12094.         smat_1.ssx[i__3].r = z__1.r, smat_1.ssx[i__3].i = z__1.i;
  12095. /*<     6 SSX( J, I)= SSX( I, J) >*/
  12096. /* L6: */
  12097.         i__3 = j + (i << 4) - 17;
  12098.         i__4 = i + (j << 4) - 17;
  12099.         smat_1.ssx[i__3].r = smat_1.ssx[i__4].r, smat_1.ssx[i__3].i = 
  12100.             smat_1.ssx[i__4].i;
  12101.     }
  12102.     }
  12103.  
  12104. /*     SET UP SSX MATRIX FOR PLANE SYMMETRY */
  12105.  
  12106. /*<       GOTO 11 >*/
  12107.     goto L11;
  12108. /*<     7 KK=1 >*/
  12109. L7:
  12110.     kk = 1;
  12111. /*<       SSX(1,1)=(1.,0.) >*/
  12112.     smat_1.ssx[0].r = 1., smat_1.ssx[0].i = 0.;
  12113. /*<       IF(( NOP.EQ.2).OR.( NOP.EQ.4).OR.( NOP.EQ.8)) GOTO 8 >*/
  12114.     if (nop == 2 || nop == 4 || nop == 8) {
  12115.     goto L8;
  12116.     }
  12117. /*<       STOP >*/
  12118.     s_stop("", 0L);
  12119. /*<     8 KA= NOP/2 >*/
  12120. L8:
  12121.     ka = nop / 2;
  12122. /*<       IF( NOP.EQ.8) KA=3 >*/
  12123.     if (nop == 8) {
  12124.     ka = 3;
  12125.     }
  12126. /*<       DO 10  K=1, KA >*/
  12127.     i__3 = ka;
  12128.     for (k = 1; k <= i__3; ++k) {
  12129. /*<       DO 9  I=1, KK >*/
  12130.     i__4 = kk;
  12131.     for (i = 1; i <= i__4; ++i) {
  12132. /*<       DO 9  J=1, KK >*/
  12133.         i__2 = kk;
  12134.         for (j = 1; j <= i__2; ++j) {
  12135. /*<       DETER= SSX( I, J) >*/
  12136.         i__1 = i + (j << 4) - 17;
  12137.         deter.r = smat_1.ssx[i__1].r, deter.i = smat_1.ssx[i__1].i;
  12138. /*<       SSX( I, J+ KK)= DETER >*/
  12139.         i__1 = i + (j + kk << 4) - 17;
  12140.         smat_1.ssx[i__1].r = deter.r, smat_1.ssx[i__1].i = deter.i;
  12141. /*<       SSX( I+ KK, J+ KK)=- DETER >*/
  12142.         i__1 = i + kk + (j + kk << 4) - 17;
  12143.         z__1.r = -deter.r, z__1.i = -deter.i;
  12144.         smat_1.ssx[i__1].r = z__1.r, smat_1.ssx[i__1].i = z__1.i;
  12145. /*<     9 SSX( I+ KK, J)= DETER >*/
  12146. /* L9: */
  12147.         i__1 = i + kk + (j << 4) - 17;
  12148.         smat_1.ssx[i__1].r = deter.r, smat_1.ssx[i__1].i = deter.i;
  12149.         }
  12150.     }
  12151. /*<    10 KK= KK*2 >*/
  12152. /* L10: */
  12153.     kk <<= 1;
  12154.     }
  12155. /*<    11 RETURN >*/
  12156. L11:
  12157.     return 0;
  12158. /*<    12 WRITE( 6,17)  NROW, NCOL >*/
  12159. L12:
  12160.     s_wsfe(&io___809);
  12161.     do_fio(&c__1, (char *)&(*nrow), (ftnlen)sizeof(integer));
  12162.     do_fio(&c__1, (char *)&(*ncol), (ftnlen)sizeof(integer));
  12163.     e_wsfe();
  12164. /*<       STOP >*/
  12165.     s_stop("", 0L);
  12166. /*<    13 WRITE( 6,18)  NROW, NCOL >*/
  12167. L13:
  12168.     s_wsfe(&io___810);
  12169.     do_fio(&c__1, (char *)&(*nrow), (ftnlen)sizeof(integer));
  12170.     do_fio(&c__1, (char *)&(*ncol), (ftnlen)sizeof(integer));
  12171.     e_wsfe();
  12172.  
  12173. /*<       STOP >*/
  12174.     s_stop("", 0L);
  12175. /*<    >*/
  12176. /*<    15 FORMAT(' SUBMATRICIES FIT IN CORE') >*/
  12177. /*<    >*/
  12178. /*<    17 FORMAT(' ERROR - INSUFFICIENT STORAGE FOR MATRIX',2I5) >*/
  12179. /*<    18 FORMAT(' SYMMETRY ERROR - NROW,NCOL=',2I5) >*/
  12180. /*<       END >*/
  12181. } /* fblock_ */
  12182.  
  12183. /* *** */
  12184. /*     DOUBLE PRECISION 6/4/85 */
  12185.  
  12186. /*<       SUBROUTINE FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11) >*/
  12187. /* Subroutine */ int fbngf_(neq, neq2, iresrv, ib11, ic11, id11, ix11)
  12188. integer *neq, *neq2, *iresrv, *ib11, *ic11, *id11, *ix11;
  12189. {
  12190.     /* Format strings */
  12191.     static char fmt_11[] = "(//,\002 N.G.F. - NUMBER OF NEW UNKNOWNS IS\002,\
  12192. i4)";
  12193.     static char fmt_8[] = "(\002 FILE STORAGE FOR NEW MATRIX SECTIONS -  ICA\
  12194. SX =\002,i2)";
  12195.     static char fmt_9[] = "(\002 B FILLED BY ROWS -\002,15x,\002NO. BLOCKS \
  12196. =\002,i3,3x,\002ROWS P\002,\002ER BLOCK =\002,i3,3x,\002ROWS IN LAST BLOCK \
  12197. =\002,i3)";
  12198.     static char fmt_10[] = "(\002 B BY COLUMNS, C AND D BY ROWS -\002,2x,\
  12199. \002NO. BLOCKS =\002,i3,4x,\002R/C PER BLOCK =\002,i3,4x,\002R/C IN LAST BLO\
  12200. CK =\002,i3)";
  12201.     static char fmt_7[] = "(\002 ERROR - INSUFFICIENT STORAGE FOR INTERACTIO\
  12202. N MATRICIES\002,\002  IRESRV,IMAT,NEQ,NEQ2 =\002,4i5)";
  12203.  
  12204.     /* Builtin functions */
  12205.     integer s_wsfe(), do_fio(), e_wsfe();
  12206.     /* Subroutine */ int s_stop();
  12207.  
  12208.     /* Local variables */
  12209.     static integer nbcd, nbln, ndln, iresx, ir;
  12210.  
  12211.     /* Fortran I/O blocks */
  12212.     static cilist io___816 = { 0, 6, 0, fmt_11, 0 };
  12213.     static cilist io___817 = { 0, 6, 0, fmt_8, 0 };
  12214.     static cilist io___818 = { 0, 6, 0, fmt_9, 0 };
  12215.     static cilist io___819 = { 0, 6, 0, fmt_10, 0 };
  12216.     static cilist io___820 = { 0, 6, 0, fmt_7, 0 };
  12217.  
  12218.  
  12219. /* *** */
  12220. /*     FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR 
  12221. */
  12222. /*     OUT-OF-CORE STORAGE. */
  12223. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  12224. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  12225. /*<    >*/
  12226. /*<       IRESX= IRESRV- IMAT >*/
  12227.     iresx = *iresrv - matpar_1.imat;
  12228. /*<       NBLN= NEQ* NEQ2 >*/
  12229.     nbln = *neq * *neq2;
  12230. /*<       NDLN= NEQ2* NEQ2 >*/
  12231.     ndln = *neq2 * *neq2;
  12232. /*<       NBCD=2* NBLN+ NDLN >*/
  12233.     nbcd = (nbln << 1) + ndln;
  12234. /*<       IF( NBCD.GT. IRESX) GOTO 1 >*/
  12235.     if (nbcd > iresx) {
  12236.     goto L1;
  12237.     }
  12238. /*<       ICASX=1 >*/
  12239.     matpar_1.icasx = 1;
  12240. /*<       IB11= IMAT+1 >*/
  12241.     *ib11 = matpar_1.imat + 1;
  12242. /*<       GOTO 2 >*/
  12243.     goto L2;
  12244. /*<     1 IF( ICASE.LT.3) GOTO 3 >*/
  12245. L1:
  12246.     if (matpar_1.icase < 3) {
  12247.     goto L3;
  12248.     }
  12249. /*<       IF( NBCD.GT. IRESRV.OR. NBLN.GT. IRESX) GOTO 3 >*/
  12250.     if (nbcd > *iresrv || nbln > iresx) {
  12251.     goto L3;
  12252.     }
  12253. /*<       ICASX=2 >*/
  12254.     matpar_1.icasx = 2;
  12255. /*<       IB11=1 >*/
  12256.     *ib11 = 1;
  12257. /*<     2 NBBX=1 >*/
  12258. L2:
  12259.     matpar_1.nbbx = 1;
  12260. /*<       NPBX= NEQ >*/
  12261.     matpar_1.npbx = *neq;
  12262. /*<       NLBX= NEQ >*/
  12263.     matpar_1.nlbx = *neq;
  12264. /*<       NBBL=1 >*/
  12265.     matpar_1.nbbl = 1;
  12266. /*<       NPBL= NEQ2 >*/
  12267.     matpar_1.npbl = *neq2;
  12268. /*<       NLBL= NEQ2 >*/
  12269.     matpar_1.nlbl = *neq2;
  12270. /*<       GOTO 5 >*/
  12271.     goto L5;
  12272. /*<     3 IR= IRESRV >*/
  12273. L3:
  12274.     ir = *iresrv;
  12275. /*<       IF( ICASE.LT.3) IR= IRESX >*/
  12276.     if (matpar_1.icase < 3) {
  12277.     ir = iresx;
  12278.     }
  12279. /*<       ICASX=3 >*/
  12280.     matpar_1.icasx = 3;
  12281. /*<       IF( NDLN.GT. IR) ICASX=4 >*/
  12282.     if (ndln > ir) {
  12283.     matpar_1.icasx = 4;
  12284.     }
  12285. /*<       NBCD=2* NEQ+ NEQ2 >*/
  12286.     nbcd = (*neq << 1) + *neq2;
  12287. /*<       NPBL= IR/ NBCD >*/
  12288.     matpar_1.npbl = ir / nbcd;
  12289. /*<       NLBL= IR/(2* NEQ2) >*/
  12290.     matpar_1.nlbl = ir / (*neq2 << 1);
  12291. /*<       IF( NLBL.LT. NPBL) NPBL= NLBL >*/
  12292.     if (matpar_1.nlbl < matpar_1.npbl) {
  12293.     matpar_1.npbl = matpar_1.nlbl;
  12294.     }
  12295. /*<       IF( ICASE.LT.3) GOTO 4 >*/
  12296.     if (matpar_1.icase < 3) {
  12297.     goto L4;
  12298.     }
  12299. /*<       NLBL= IRESX/ NEQ >*/
  12300.     matpar_1.nlbl = iresx / *neq;
  12301. /*<       IF( NLBL.LT. NPBL) NPBL= NLBL >*/
  12302.     if (matpar_1.nlbl < matpar_1.npbl) {
  12303.     matpar_1.npbl = matpar_1.nlbl;
  12304.     }
  12305. /*<     4 IF( NPBL.LT.1) GOTO 6 >*/
  12306. L4:
  12307.     if (matpar_1.npbl < 1) {
  12308.     goto L6;
  12309.     }
  12310. /*<       NBBL=( NEQ2-1)/ NPBL >*/
  12311.     matpar_1.nbbl = (*neq2 - 1) / matpar_1.npbl;
  12312. /*<       NLBL= NEQ2- NBBL* NPBL >*/
  12313.     matpar_1.nlbl = *neq2 - matpar_1.nbbl * matpar_1.npbl;
  12314. /*<       NBBL= NBBL+1 >*/
  12315.     ++matpar_1.nbbl;
  12316. /*<       NBLN= NEQ* NPBL >*/
  12317.     nbln = *neq * matpar_1.npbl;
  12318. /*<       IR= IR- NBLN >*/
  12319.     ir -= nbln;
  12320. /*<       NPBX= IR/ NEQ2 >*/
  12321.     matpar_1.npbx = ir / *neq2;
  12322. /*<       IF( NPBX.GT. NEQ) NPBX= NEQ >*/
  12323.     if (matpar_1.npbx > *neq) {
  12324.     matpar_1.npbx = *neq;
  12325.     }
  12326. /*<       NBBX=( NEQ-1)/ NPBX >*/
  12327.     matpar_1.nbbx = (*neq - 1) / matpar_1.npbx;
  12328. /*<       NLBX= NEQ- NBBX* NPBX >*/
  12329.     matpar_1.nlbx = *neq - matpar_1.nbbx * matpar_1.npbx;
  12330. /*<       NBBX= NBBX+1 >*/
  12331.     ++matpar_1.nbbx;
  12332. /*<       IB11=1 >*/
  12333.     *ib11 = 1;
  12334. /*<       IF( ICASE.LT.3) IB11= IMAT+1 >*/
  12335.     if (matpar_1.icase < 3) {
  12336.     *ib11 = matpar_1.imat + 1;
  12337.     }
  12338. /*<     5 IC11= IB11+ NBLN >*/
  12339. L5:
  12340.     *ic11 = *ib11 + nbln;
  12341. /*<       ID11= IC11+ NBLN >*/
  12342.     *id11 = *ic11 + nbln;
  12343. /*<       IX11= IMAT+1 >*/
  12344.     *ix11 = matpar_1.imat + 1;
  12345. /*<       WRITE( 6,11)  NEQ2 >*/
  12346.     s_wsfe(&io___816);
  12347.     do_fio(&c__1, (char *)&(*neq2), (ftnlen)sizeof(integer));
  12348.     e_wsfe();
  12349. /*<       IF( ICASX.EQ.1) RETURN >*/
  12350.     if (matpar_1.icasx == 1) {
  12351.     return 0;
  12352.     }
  12353. /*<       WRITE( 6,8)  ICASX >*/
  12354.     s_wsfe(&io___817);
  12355.     do_fio(&c__1, (char *)&matpar_1.icasx, (ftnlen)sizeof(integer));
  12356.     e_wsfe();
  12357. /*<       WRITE( 6,9)  NBBX, NPBX, NLBX >*/
  12358.     s_wsfe(&io___818);
  12359.     do_fio(&c__1, (char *)&matpar_1.nbbx, (ftnlen)sizeof(integer));
  12360.     do_fio(&c__1, (char *)&matpar_1.npbx, (ftnlen)sizeof(integer));
  12361.     do_fio(&c__1, (char *)&matpar_1.nlbx, (ftnlen)sizeof(integer));
  12362.     e_wsfe();
  12363. /*<       WRITE( 6,10)  NBBL, NPBL, NLBL >*/
  12364.     s_wsfe(&io___819);
  12365.     do_fio(&c__1, (char *)&matpar_1.nbbl, (ftnlen)sizeof(integer));
  12366.     do_fio(&c__1, (char *)&matpar_1.npbl, (ftnlen)sizeof(integer));
  12367.     do_fio(&c__1, (char *)&matpar_1.nlbl, (ftnlen)sizeof(integer));
  12368.     e_wsfe();
  12369. /*<       RETURN >*/
  12370.     return 0;
  12371. /*<     6 WRITE( 6,7)  IRESRV, IMAT, NEQ, NEQ2 >*/
  12372. L6:
  12373.     s_wsfe(&io___820);
  12374.     do_fio(&c__1, (char *)&(*iresrv), (ftnlen)sizeof(integer));
  12375.     do_fio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
  12376.     do_fio(&c__1, (char *)&(*neq), (ftnlen)sizeof(integer));
  12377.     do_fio(&c__1, (char *)&(*neq2), (ftnlen)sizeof(integer));
  12378.     e_wsfe();
  12379.  
  12380. /*<       STOP >*/
  12381.     s_stop("", 0L);
  12382. /*<    >*/
  12383. /*<     8 FORMAT(48H FILE STORAGE FOR NEW MATRIX SECTIONS -  ICASX =,I2) >*/
  12384. /*<    >*/
  12385. /*<    >*/
  12386. /*<    11 FORMAT(//,35H N.G.F. - NUMBER OF NEW UNKNOWNS IS,I4) >*/
  12387. /*<       END >*/
  12388. } /* fbngf_ */
  12389.  
  12390. /* *** */
  12391. /*     DOUBLE PRECISION 6/4/85 */
  12392.  
  12393. /*<       SUBROUTINE FFLD( THET, PHI, ETH, EPH) >*/
  12394. /* Subroutine */ int ffld_(thet, phi, eth, eph)
  12395. doublereal *thet, *phi;
  12396. doublecomplex *eth, *eph;
  12397. {
  12398.     /* Initialized data */
  12399.  
  12400.     static doublereal pi = 3.141592654;
  12401.     static doublereal tp = 6.283185308;
  12402.     static doublereal eta = 376.73;
  12403.     static struct {
  12404.     doublereal e_1[3];
  12405.     } equiv_2 = { 0., -29.97922085, 0. };
  12406.  
  12407.  
  12408.     /* System generated locals */
  12409.     integer i__1, i__2, i__3;
  12410.     doublereal d__1, d__2;
  12411.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
  12412.  
  12413.     /* Builtin functions */
  12414.     double sin(), cos();
  12415.     void z_sqrt(), z_div();
  12416.     double tan(), sqrt(), log();
  12417.  
  12418.     /* Local variables */
  12419.     static doublereal darg, sill, rozs, a, b, c, d;
  12420.     static integer i, k;
  12421.     static doublereal omega;
  12422.     extern /* Subroutine */ int fflds_();
  12423. #define const_ ((doublecomplex *)&equiv_2)
  12424.     static doublereal tthet;
  12425. #define consx ((doublereal *)&equiv_2)
  12426.     static doublecomplex zscrn, zrsin;
  12427.     static doublereal el, dr;
  12428.     static integer ip;
  12429.     static doublecomplex ex, ey, ez, gx, gy, gz;
  12430.     static doublereal rr, ri;
  12431. #define cab ((doublereal *)&data_1 + 3000)
  12432. #define sab ((doublereal *)&data_1 + 3600)
  12433.     static doublecomplex cdp, exa, ccx, ccy, ccz, cix, ciy, ciz, rrh;
  12434.     static doublereal bot, phx, phy, too, top, thx;
  12435.     static doublecomplex tix, tiy, tiz;
  12436.     static doublereal thy, thz;
  12437.     static doublecomplex rrv;
  12438.     static doublereal roz, rox, roy, boo, arg, rfl, rrz;
  12439.     static doublecomplex rrh1, rrh2, rrv1, rrv2;
  12440.  
  12441. /* *** */
  12442.  
  12443. /*     FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS, */
  12444. /*     THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED */
  12445.  
  12446. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  12447. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  12448. /*<    >*/
  12449. /*<    >*/
  12450. /*<    >*/
  12451. /*<       COMMON  /ANGL/ SALP( NM) >*/
  12452. /*<    >*/
  12453. /*<    >*/
  12454. /*<       DIMENSION  CAB(1), SAB(1), CONSX(2) >*/
  12455. /*<       EQUIVALENCE(CAB,ALP),(SAB,BET),(CONST,CONSX) >*/
  12456. /*<       DATA   PI, TP, ETA/3.141592654D+0,6.283185308D+0,376.73/ >*/
  12457. /*<       DATA   CONSX/0.,-29.97922085D+0/ >*/
  12458. /*<       PHX=- SIN( PHI) >*/
  12459.     phx = -sin(*phi);
  12460. /*<       PHY= COS( PHI) >*/
  12461.     phy = cos(*phi);
  12462. /*<       ROZ= COS( THET) >*/
  12463.     roz = cos(*thet);
  12464. /*<       ROZS= ROZ >*/
  12465.     rozs = roz;
  12466. /*<       THX= ROZ* PHY >*/
  12467.     thx = roz * phy;
  12468. /*<       THY=- ROZ* PHX >*/
  12469.     thy = -roz * phx;
  12470. /*<       THZ=- SIN( THET) >*/
  12471.     thz = -sin(*thet);
  12472. /*<       ROX=- THZ* PHY >*/
  12473.     rox = -thz * phy;
  12474. /*<       ROY= THZ* PHX >*/
  12475.     roy = thz * phx;
  12476.  
  12477. /*     LOOP FOR STRUCTURE IMAGE IF ANY */
  12478.  
  12479. /*<       IF( N.EQ.0) GOTO 20 >*/
  12480.     if (data_1.n == 0) {
  12481.     goto L20;
  12482.     }
  12483.  
  12484. /*     CALCULATION OF REFLECTION COEFFECIENTS */
  12485.  
  12486. /*<       DO 19  K=1, KSYMP >*/
  12487.     i__1 = gnd_1.ksymp;
  12488.     for (k = 1; k <= i__1; ++k) {
  12489. /*<       IF( K.EQ.1) GOTO 4 >*/
  12490.     if (k == 1) {
  12491.         goto L4;
  12492.     }
  12493.  
  12494. /*     FOR PERFECT GROUND */
  12495.  
  12496. /*<       IF( IPERF.NE.1) GOTO 1 >*/
  12497.     if (gnd_1.iperf != 1) {
  12498.         goto L1;
  12499.     }
  12500. /*<       RRV=-(1.,0.) >*/
  12501.     rrv.r = -1., rrv.i = 0.;
  12502. /*<       RRH=-(1.,0.) >*/
  12503.     rrh.r = -1., rrh.i = 0.;
  12504.  
  12505. /*     FOR INFINITE PLANAR GROUND */
  12506.  
  12507. /*<       GOTO 2 >*/
  12508.     goto L2;
  12509. /*<     1 ZRSIN= SQRT(1.- ZRATI* ZRATI* THZ* THZ) >*/
  12510. L1:
  12511.     z__5.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i * 
  12512.         gnd_1.zrati.i, z__5.i = gnd_1.zrati.r * gnd_1.zrati.i + 
  12513.         gnd_1.zrati.i * gnd_1.zrati.r;
  12514.     z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
  12515.     z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
  12516.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  12517.     z_sqrt(&z__1, &z__2);
  12518.     zrsin.r = z__1.r, zrsin.i = z__1.i;
  12519. /*<       RRV=-( ROZ- ZRATI* ZRSIN)/( ROZ+ ZRATI* ZRSIN) >*/
  12520.     z__4.r = gnd_1.zrati.r * zrsin.r - gnd_1.zrati.i * zrsin.i, z__4.i = 
  12521.         gnd_1.zrati.r * zrsin.i + gnd_1.zrati.i * zrsin.r;
  12522.     z__3.r = roz - z__4.r, z__3.i = -z__4.i;
  12523.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  12524.     z__6.r = gnd_1.zrati.r * zrsin.r - gnd_1.zrati.i * zrsin.i, z__6.i = 
  12525.         gnd_1.zrati.r * zrsin.i + gnd_1.zrati.i * zrsin.r;
  12526.     z__5.r = roz + z__6.r, z__5.i = z__6.i;
  12527.     z_div(&z__1, &z__2, &z__5);
  12528.     rrv.r = z__1.r, rrv.i = z__1.i;
  12529. /*<       RRH=( ZRATI* ROZ- ZRSIN)/( ZRATI* ROZ+ ZRSIN) >*/
  12530.     z__3.r = roz * gnd_1.zrati.r, z__3.i = roz * gnd_1.zrati.i;
  12531.     z__2.r = z__3.r - zrsin.r, z__2.i = z__3.i - zrsin.i;
  12532.     z__5.r = roz * gnd_1.zrati.r, z__5.i = roz * gnd_1.zrati.i;
  12533.     z__4.r = z__5.r + zrsin.r, z__4.i = z__5.i + zrsin.i;
  12534.     z_div(&z__1, &z__2, &z__4);
  12535.     rrh.r = z__1.r, rrh.i = z__1.i;
  12536.  
  12537. /*     FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED */
  12538.  
  12539.  
  12540. /*<     2 IF( IFAR.LE.1) GOTO 3 >*/
  12541. L2:
  12542.     if (gnd_1.ifar <= 1) {
  12543.         goto L3;
  12544.     }
  12545. /*<       RRV1= RRV >*/
  12546.     rrv1.r = rrv.r, rrv1.i = rrv.i;
  12547. /*<       RRH1= RRH >*/
  12548.     rrh1.r = rrh.r, rrh1.i = rrh.i;
  12549. /*<       TTHET= TAN( THET) >*/
  12550.     tthet = tan(*thet);
  12551. /*<       IF( IFAR.EQ.4) GOTO 3 >*/
  12552.     if (gnd_1.ifar == 4) {
  12553.         goto L3;
  12554.     }
  12555. /*<       ZRSIN= SQRT(1.- ZRATI2* ZRATI2* THZ* THZ) >*/
  12556.     z__5.r = gnd_1.zrati2.r * gnd_1.zrati2.r - gnd_1.zrati2.i * 
  12557.         gnd_1.zrati2.i, z__5.i = gnd_1.zrati2.r * gnd_1.zrati2.i + 
  12558.         gnd_1.zrati2.i * gnd_1.zrati2.r;
  12559.     z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
  12560.     z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
  12561.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  12562.     z_sqrt(&z__1, &z__2);
  12563.     zrsin.r = z__1.r, zrsin.i = z__1.i;
  12564. /*<       RRV2=-( ROZ- ZRATI2* ZRSIN)/( ROZ+ ZRATI2* ZRSIN) >*/
  12565.     z__4.r = gnd_1.zrati2.r * zrsin.r - gnd_1.zrati2.i * zrsin.i, z__4.i =
  12566.          gnd_1.zrati2.r * zrsin.i + gnd_1.zrati2.i * zrsin.r;
  12567.     z__3.r = roz - z__4.r, z__3.i = -z__4.i;
  12568.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  12569.     z__6.r = gnd_1.zrati2.r * zrsin.r - gnd_1.zrati2.i * zrsin.i, z__6.i =
  12570.          gnd_1.zrati2.r * zrsin.i + gnd_1.zrati2.i * zrsin.r;
  12571.     z__5.r = roz + z__6.r, z__5.i = z__6.i;
  12572.     z_div(&z__1, &z__2, &z__5);
  12573.     rrv2.r = z__1.r, rrv2.i = z__1.i;
  12574. /*<       RRH2=( ZRATI2* ROZ- ZRSIN)/( ZRATI2* ROZ+ ZRSIN) >*/
  12575.     z__3.r = roz * gnd_1.zrati2.r, z__3.i = roz * gnd_1.zrati2.i;
  12576.     z__2.r = z__3.r - zrsin.r, z__2.i = z__3.i - zrsin.i;
  12577.     z__5.r = roz * gnd_1.zrati2.r, z__5.i = roz * gnd_1.zrati2.i;
  12578.     z__4.r = z__5.r + zrsin.r, z__4.i = z__5.i + zrsin.i;
  12579.     z_div(&z__1, &z__2, &z__4);
  12580.     rrh2.r = z__1.r, rrh2.i = z__1.i;
  12581. /*<       DARG=- TP*2.* CH* ROZ >*/
  12582.     d__2 = -tp * 2.;
  12583.     d__1 = d__2 * gnd_1.ch;
  12584.     darg = d__1 * roz;
  12585. /*<     3 ROZ=- ROZ >*/
  12586. L3:
  12587.     roz = -roz;
  12588. /*<       CCX= CIX >*/
  12589.     ccx.r = cix.r, ccx.i = cix.i;
  12590. /*<       CCY= CIY >*/
  12591.     ccy.r = ciy.r, ccy.i = ciy.i;
  12592. /*<       CCZ= CIZ >*/
  12593.     ccz.r = ciz.r, ccz.i = ciz.i;
  12594. /*<     4 CIX=(0.,0.) >*/
  12595. L4:
  12596.     cix.r = 0., cix.i = 0.;
  12597. /*<       CIY=(0.,0.) >*/
  12598.     ciy.r = 0., ciy.i = 0.;
  12599.  
  12600. /*     LOOP OVER STRUCTURE SEGMENTS */
  12601.  
  12602. /*<       CIZ=(0.,0.) >*/
  12603.     ciz.r = 0., ciz.i = 0.;
  12604. /*<       DO 17  I=1, N >*/
  12605.     i__2 = data_1.n;
  12606.     for (i = 1; i <= i__2; ++i) {
  12607. /*<       OMEGA=-( ROX* CAB( I)+ ROY* SAB( I)+ ROZ* SALP( I)) >*/
  12608.         d__1 = rox * cab[i - 1] + roy * sab[i - 1];
  12609.         omega = -(d__1 + roz * angl_1.salp[i - 1]);
  12610. /*<       EL= PI* SI( I) >*/
  12611.         el = pi * data_1.si[i - 1];
  12612. /*<       SILL= OMEGA* EL >*/
  12613.         sill = omega * el;
  12614. /*<       TOP= EL+ SILL >*/
  12615.         top = el + sill;
  12616. /*<       BOT= EL- SILL >*/
  12617.         bot = el - sill;
  12618. /*<       IF( ABS( OMEGA).LT.1.D-7) GOTO 5 >*/
  12619.         if (abs(omega) < 1e-7) {
  12620.         goto L5;
  12621.         }
  12622. /*<       A=2.* SIN( SILL)/ OMEGA >*/
  12623.         a = sin(sill) * 2. / omega;
  12624. /*<       GOTO 6 >*/
  12625.         goto L6;
  12626. /*<     5 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL >*/
  12627. L5:
  12628.         d__2 = omega * omega;
  12629.         d__1 = d__2 * el;
  12630.         a = (2. - d__1 * el / 3.) * el;
  12631. /*<     6 IF( ABS( TOP).LT.1.D-7) GOTO 7 >*/
  12632. L6:
  12633.         if (abs(top) < 1e-7) {
  12634.         goto L7;
  12635.         }
  12636. /*<       TOO= SIN( TOP)/ TOP >*/
  12637.         too = sin(top) / top;
  12638. /*<       GOTO 8 >*/
  12639.         goto L8;
  12640. /*<     7 TOO=1.- TOP* TOP/6. >*/
  12641. L7:
  12642.         too = 1. - top * top / 6.;
  12643. /*<     8 IF( ABS( BOT).LT.1.D-7) GOTO 9 >*/
  12644. L8:
  12645.         if (abs(bot) < 1e-7) {
  12646.         goto L9;
  12647.         }
  12648. /*<       BOO= SIN( BOT)/ BOT >*/
  12649.         boo = sin(bot) / bot;
  12650. /*<       GOTO 10 >*/
  12651.         goto L10;
  12652. /*<     9 BOO=1.- BOT* BOT/6. >*/
  12653. L9:
  12654.         boo = 1. - bot * bot / 6.;
  12655. /*<    10 B= EL*( BOO- TOO) >*/
  12656. L10:
  12657.         b = el * (boo - too);
  12658. /*<       C= EL*( BOO+ TOO) >*/
  12659.         c = el * (boo + too);
  12660. /*<       RR= A* AIR( I)+ B* BII( I)+ C* CIR( I) >*/
  12661.         d__1 = a * crnt_1.air[i - 1] + b * crnt_1.bii[i - 1];
  12662.         rr = d__1 + c * crnt_1.cir[i - 1];
  12663. /*<       RI= A* AII( I)- B* BIR( I)+ C* CII( I) >*/
  12664.         ri = a * crnt_1.aii[i - 1] - b * crnt_1.bir[i - 1] + c * 
  12665.             crnt_1.cii[i - 1];
  12666. /*<       ARG= TP*( X( I)* ROX+ Y( I)* ROY+ Z( I)* ROZ) >*/
  12667.         d__1 = data_1.x[i - 1] * rox + data_1.y[i - 1] * roy;
  12668.         arg = tp * (d__1 + data_1.z[i - 1] * roz);
  12669. /*<       IF( K.EQ.2.AND. IFAR.GE.2) GOTO 11 >*/
  12670.         if (k == 2 && gnd_1.ifar >= 2) {
  12671.         goto L11;
  12672.         }
  12673.  
  12674. /*     SUMMATION FOR FAR FIELD INTEGRAL */
  12675.  
  12676. /*<       EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI) >*/
  12677.         d__1 = cos(arg);
  12678.         d__2 = sin(arg);
  12679.         z__2.r = d__1, z__2.i = d__2;
  12680.         z__3.r = rr, z__3.i = ri;
  12681.         z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * 
  12682.             z__3.i + z__2.i * z__3.r;
  12683.         exa.r = z__1.r, exa.i = z__1.i;
  12684. /*<       CIX= CIX+ EXA* CAB( I) >*/
  12685.         i__3 = i - 1;
  12686.         z__2.r = cab[i__3] * exa.r, z__2.i = cab[i__3] * exa.i;
  12687.         z__1.r = cix.r + z__2.r, z__1.i = cix.i + z__2.i;
  12688.         cix.r = z__1.r, cix.i = z__1.i;
  12689. /*<       CIY= CIY+ EXA* SAB( I) >*/
  12690.         i__3 = i - 1;
  12691.         z__2.r = sab[i__3] * exa.r, z__2.i = sab[i__3] * exa.i;
  12692.         z__1.r = ciy.r + z__2.r, z__1.i = ciy.i + z__2.i;
  12693.         ciy.r = z__1.r, ciy.i = z__1.i;
  12694. /*<       CIZ= CIZ+ EXA* SALP( I) >*/
  12695.         i__3 = i - 1;
  12696.         z__2.r = angl_1.salp[i__3] * exa.r, z__2.i = angl_1.salp[i__3] * 
  12697.             exa.i;
  12698.         z__1.r = ciz.r + z__2.r, z__1.i = ciz.i + z__2.i;
  12699.         ciz.r = z__1.r, ciz.i = z__1.i;
  12700.  
  12701. /*     CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREE
  12702. N */
  12703. /*     PROBLEMS. */
  12704.  
  12705. /*<       GOTO 17 >*/
  12706.         goto L17;
  12707.  
  12708. /*     SPECULAR POINT DISTANCE */
  12709.  
  12710. /*<    11 DR= Z( I)* TTHET >*/
  12711. L11:
  12712.         dr = data_1.z[i - 1] * tthet;
  12713. /*<       D= DR* PHY+ X( I) >*/
  12714.         d = dr * phy + data_1.x[i - 1];
  12715. /*<       IF( IFAR.EQ.2) GOTO 13 >*/
  12716.         if (gnd_1.ifar == 2) {
  12717.         goto L13;
  12718.         }
  12719. /*<       D= SQRT( D* D+( Y( I)- DR* PHX)**2) >*/
  12720. /* Computing 2nd power */
  12721.         d__1 = data_1.y[i - 1] - dr * phx;
  12722.         d = sqrt(d * d + d__1 * d__1);
  12723. /*<       IF( IFAR.EQ.3) GOTO 13 >*/
  12724.         if (gnd_1.ifar == 3) {
  12725.         goto L13;
  12726.         }
  12727.  
  12728. /*     RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT */
  12729.  
  12730. /*<       IF(( SCRWL- D).LT.0.) GOTO 12 >*/
  12731.         if (gnd_1.scrwl - d < 0.) {
  12732.         goto L12;
  12733.         }
  12734. /*<       D= D+ T2 >*/
  12735.         d += gnd_1.t2;
  12736. /*<       ZSCRN= T1* D* LOG( D/ T2) >*/
  12737.         z__2.r = d * gnd_1.t1.r, z__2.i = d * gnd_1.t1.i;
  12738.         d__1 = log(d / gnd_1.t2);
  12739.         z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  12740.         zscrn.r = z__1.r, zscrn.i = z__1.i;
  12741. /*<       ZSCRN=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN) >*/
  12742.         z__2.r = zscrn.r * gnd_1.zrati.r - zscrn.i * gnd_1.zrati.i, 
  12743.             z__2.i = zscrn.r * gnd_1.zrati.i + zscrn.i * 
  12744.             gnd_1.zrati.r;
  12745.         z__4.r = eta * gnd_1.zrati.r, z__4.i = eta * gnd_1.zrati.i;
  12746.         z__3.r = z__4.r + zscrn.r, z__3.i = z__4.i + zscrn.i;
  12747.         z_div(&z__1, &z__2, &z__3);
  12748.         zscrn.r = z__1.r, zscrn.i = z__1.i;
  12749. /*<       ZRSIN= SQRT(1.- ZSCRN* ZSCRN* THZ* THZ) >*/
  12750.         z__5.r = zscrn.r * zscrn.r - zscrn.i * zscrn.i, z__5.i = zscrn.r *
  12751.              zscrn.i + zscrn.i * zscrn.r;
  12752.         z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
  12753.         z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
  12754.         z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  12755.         z_sqrt(&z__1, &z__2);
  12756.         zrsin.r = z__1.r, zrsin.i = z__1.i;
  12757. /*<       RRV=( ROZ+ ZSCRN* ZRSIN)/(- ROZ+ ZSCRN* ZRSIN) >*/
  12758.         z__3.r = zscrn.r * zrsin.r - zscrn.i * zrsin.i, z__3.i = zscrn.r *
  12759.              zrsin.i + zscrn.i * zrsin.r;
  12760.         z__2.r = roz + z__3.r, z__2.i = z__3.i;
  12761.         d__1 = -roz;
  12762.         z__5.r = zscrn.r * zrsin.r - zscrn.i * zrsin.i, z__5.i = zscrn.r *
  12763.              zrsin.i + zscrn.i * zrsin.r;
  12764.         z__4.r = d__1 + z__5.r, z__4.i = z__5.i;
  12765.         z_div(&z__1, &z__2, &z__4);
  12766.         rrv.r = z__1.r, rrv.i = z__1.i;
  12767. /*<       RRH=( ZSCRN* ROZ+ ZRSIN)/( ZSCRN* ROZ- ZRSIN) >*/
  12768.         z__3.r = roz * zscrn.r, z__3.i = roz * zscrn.i;
  12769.         z__2.r = z__3.r + zrsin.r, z__2.i = z__3.i + zrsin.i;
  12770.         z__5.r = roz * zscrn.r, z__5.i = roz * zscrn.i;
  12771.         z__4.r = z__5.r - zrsin.r, z__4.i = z__5.i - zrsin.i;
  12772.         z_div(&z__1, &z__2, &z__4);
  12773.         rrh.r = z__1.r, rrh.i = z__1.i;
  12774. /*<       GOTO 16 >*/
  12775.         goto L16;
  12776. /*<    12 IF( IFAR.EQ.4) GOTO 14 >*/
  12777. L12:
  12778.         if (gnd_1.ifar == 4) {
  12779.         goto L14;
  12780.         }
  12781. /*<       IF( IFAR.EQ.5) D= DR* PHY+ X( I) >*/
  12782.         if (gnd_1.ifar == 5) {
  12783.         d = dr * phy + data_1.x[i - 1];
  12784.         }
  12785. /*<    13 IF(( CL- D).LE.0.) GOTO 15 >*/
  12786. L13:
  12787.         if (gnd_1.cl - d <= 0.) {
  12788.         goto L15;
  12789.         }
  12790. /*<    14 RRV= RRV1 >*/
  12791. L14:
  12792.         rrv.r = rrv1.r, rrv.i = rrv1.i;
  12793. /*<       RRH= RRH1 >*/
  12794.         rrh.r = rrh1.r, rrh.i = rrh1.i;
  12795. /*<       GOTO 16 >*/
  12796.         goto L16;
  12797. /*<    15 RRV= RRV2 >*/
  12798. L15:
  12799.         rrv.r = rrv2.r, rrv.i = rrv2.i;
  12800. /*<       RRH= RRH2 >*/
  12801.         rrh.r = rrh2.r, rrh.i = rrh2.i;
  12802. /*<       ARG= ARG+ DARG >*/
  12803.         arg += darg;
  12804.  
  12805. /*     CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION C
  12806. OEF. , */
  12807. /*     FOR CLIFF AND GROUND SCREEN PROBLEMS */
  12808.  
  12809. /*<    16 EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI) >*/
  12810. L16:
  12811.         d__1 = cos(arg);
  12812.         d__2 = sin(arg);
  12813.         z__2.r = d__1, z__2.i = d__2;
  12814.         z__3.r = rr, z__3.i = ri;
  12815.         z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * 
  12816.             z__3.i + z__2.i * z__3.r;
  12817.         exa.r = z__1.r, exa.i = z__1.i;
  12818. /*<       TIX= EXA* CAB( I) >*/
  12819.         i__3 = i - 1;
  12820.         z__1.r = cab[i__3] * exa.r, z__1.i = cab[i__3] * exa.i;
  12821.         tix.r = z__1.r, tix.i = z__1.i;
  12822. /*<       TIY= EXA* SAB( I) >*/
  12823.         i__3 = i - 1;
  12824.         z__1.r = sab[i__3] * exa.r, z__1.i = sab[i__3] * exa.i;
  12825.         tiy.r = z__1.r, tiy.i = z__1.i;
  12826. /*<       TIZ= EXA* SALP( I) >*/
  12827.         i__3 = i - 1;
  12828.         z__1.r = angl_1.salp[i__3] * exa.r, z__1.i = angl_1.salp[i__3] * 
  12829.             exa.i;
  12830.         tiz.r = z__1.r, tiz.i = z__1.i;
  12831. /*<       CDP=( TIX* PHX+ TIY* PHY)*( RRH- RRV) >*/
  12832.         z__3.r = phx * tix.r, z__3.i = phx * tix.i;
  12833.         z__4.r = phy * tiy.r, z__4.i = phy * tiy.i;
  12834.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  12835.         z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
  12836.         z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * 
  12837.             z__5.i + z__2.i * z__5.r;
  12838.         cdp.r = z__1.r, cdp.i = z__1.i;
  12839. /*<       CIX= CIX+ TIX* RRV+ CDP* PHX >*/
  12840.         z__3.r = tix.r * rrv.r - tix.i * rrv.i, z__3.i = tix.r * rrv.i + 
  12841.             tix.i * rrv.r;
  12842.         z__2.r = cix.r + z__3.r, z__2.i = cix.i + z__3.i;
  12843.         z__4.r = phx * cdp.r, z__4.i = phx * cdp.i;
  12844.         z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  12845.         cix.r = z__1.r, cix.i = z__1.i;
  12846. /*<       CIY= CIY+ TIY* RRV+ CDP* PHY >*/
  12847.         z__3.r = tiy.r * rrv.r - tiy.i * rrv.i, z__3.i = tiy.r * rrv.i + 
  12848.             tiy.i * rrv.r;
  12849.         z__2.r = ciy.r + z__3.r, z__2.i = ciy.i + z__3.i;
  12850.         z__4.r = phy * cdp.r, z__4.i = phy * cdp.i;
  12851.         z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  12852.         ciy.r = z__1.r, ciy.i = z__1.i;
  12853. /*<       CIZ= CIZ- TIZ* RRV >*/
  12854.         z__2.r = tiz.r * rrv.r - tiz.i * rrv.i, z__2.i = tiz.r * rrv.i + 
  12855.             tiz.i * rrv.r;
  12856.         z__1.r = ciz.r - z__2.r, z__1.i = ciz.i - z__2.i;
  12857.         ciz.r = z__1.r, ciz.i = z__1.i;
  12858. /*<    17 CONTINUE >*/
  12859. L17:
  12860.         ;
  12861.     }
  12862. /*<       IF( K.EQ.1) GOTO 19 >*/
  12863.     if (k == 1) {
  12864.         goto L19;
  12865.     }
  12866.  
  12867. /*     CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GRO
  12868. UND */
  12869.  
  12870. /*<       IF( IFAR.GE.2) GOTO 18 >*/
  12871.     if (gnd_1.ifar >= 2) {
  12872.         goto L18;
  12873.     }
  12874. /*<       CDP=( CIX* PHX+ CIY* PHY)*( RRH- RRV) >*/
  12875.     z__3.r = phx * cix.r, z__3.i = phx * cix.i;
  12876.     z__4.r = phy * ciy.r, z__4.i = phy * ciy.i;
  12877.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  12878.     z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
  12879.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i 
  12880.         + z__2.i * z__5.r;
  12881.     cdp.r = z__1.r, cdp.i = z__1.i;
  12882. /*<       CIX= CCX+ CIX* RRV+ CDP* PHX >*/
  12883.     z__3.r = cix.r * rrv.r - cix.i * rrv.i, z__3.i = cix.r * rrv.i + 
  12884.         cix.i * rrv.r;
  12885.     z__2.r = ccx.r + z__3.r, z__2.i = ccx.i + z__3.i;
  12886.     z__4.r = phx * cdp.r, z__4.i = phx * cdp.i;
  12887.     z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  12888.     cix.r = z__1.r, cix.i = z__1.i;
  12889. /*<       CIY= CCY+ CIY* RRV+ CDP* PHY >*/
  12890.     z__3.r = ciy.r * rrv.r - ciy.i * rrv.i, z__3.i = ciy.r * rrv.i + 
  12891.         ciy.i * rrv.r;
  12892.     z__2.r = ccy.r + z__3.r, z__2.i = ccy.i + z__3.i;
  12893.     z__4.r = phy * cdp.r, z__4.i = phy * cdp.i;
  12894.     z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  12895.     ciy.r = z__1.r, ciy.i = z__1.i;
  12896. /*<       CIZ= CCZ- CIZ* RRV >*/
  12897.     z__2.r = ciz.r * rrv.r - ciz.i * rrv.i, z__2.i = ciz.r * rrv.i + 
  12898.         ciz.i * rrv.r;
  12899.     z__1.r = ccz.r - z__2.r, z__1.i = ccz.i - z__2.i;
  12900.     ciz.r = z__1.r, ciz.i = z__1.i;
  12901. /*<       GOTO 19 >*/
  12902.     goto L19;
  12903. /*<    18 CIX= CIX+ CCX >*/
  12904. L18:
  12905.     z__1.r = cix.r + ccx.r, z__1.i = cix.i + ccx.i;
  12906.     cix.r = z__1.r, cix.i = z__1.i;
  12907. /*<       CIY= CIY+ CCY >*/
  12908.     z__1.r = ciy.r + ccy.r, z__1.i = ciy.i + ccy.i;
  12909.     ciy.r = z__1.r, ciy.i = z__1.i;
  12910. /*<       CIZ= CIZ+ CCZ >*/
  12911.     z__1.r = ciz.r + ccz.r, z__1.i = ciz.i + ccz.i;
  12912.     ciz.r = z__1.r, ciz.i = z__1.i;
  12913. /*<    19 CONTINUE >*/
  12914. L19:
  12915.     ;
  12916.     }
  12917. /*<       IF( M.GT.0) GOTO 21 >*/
  12918.     if (data_1.m > 0) {
  12919.     goto L21;
  12920.     }
  12921. /*<       ETH=( CIX* THX+ CIY* THY+ CIZ* THZ)* CONST >*/
  12922.     z__4.r = thx * cix.r, z__4.i = thx * cix.i;
  12923.     z__5.r = thy * ciy.r, z__5.i = thy * ciy.i;
  12924.     z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
  12925.     z__6.r = thz * ciz.r, z__6.i = thz * ciz.i;
  12926.     z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
  12927.     z__1.r = z__2.r * const_->r - z__2.i * const_->i, z__1.i = z__2.r * 
  12928.         const_->i + z__2.i * const_->r;
  12929.     eth->r = z__1.r, eth->i = z__1.i;
  12930. /*<       EPH=( CIX* PHX+ CIY* PHY)* CONST >*/
  12931.     z__3.r = phx * cix.r, z__3.i = phx * cix.i;
  12932.     z__4.r = phy * ciy.r, z__4.i = phy * ciy.i;
  12933.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  12934.     z__1.r = z__2.r * const_->r - z__2.i * const_->i, z__1.i = z__2.r * 
  12935.         const_->i + z__2.i * const_->r;
  12936.     eph->r = z__1.r, eph->i = z__1.i;
  12937. /*<       RETURN >*/
  12938.     return 0;
  12939. /*<    20 CIX=(0.,0.) >*/
  12940. L20:
  12941.     cix.r = 0., cix.i = 0.;
  12942. /*<       CIY=(0.,0.) >*/
  12943.     ciy.r = 0., ciy.i = 0.;
  12944. /*<       CIZ=(0.,0.) >*/
  12945.     ciz.r = 0., ciz.i = 0.;
  12946.  
  12947. /*     ELECTRIC FIELD COMPONENTS */
  12948.  
  12949. /*<    21 ROZ= ROZS >*/
  12950. L21:
  12951.     roz = rozs;
  12952. /*<       RFL=-1. >*/
  12953.     rfl = -1.;
  12954. /*<       DO 25  IP=1, KSYMP >*/
  12955.     i__1 = gnd_1.ksymp;
  12956.     for (ip = 1; ip <= i__1; ++ip) {
  12957. /*<       RFL=- RFL >*/
  12958.     rfl = -rfl;
  12959. /*<       RRZ= ROZ* RFL >*/
  12960.     rrz = roz * rfl;
  12961. /*<       CALL FFLDS( ROX, ROY, RRZ, CUR( N+1), GX, GY, GZ) >*/
  12962.     fflds_(&rox, &roy, &rrz, &crnt_1.cur[data_1.n], &gx, &gy, &gz);
  12963. /*<       IF( IP.EQ.2) GOTO 22 >*/
  12964.     if (ip == 2) {
  12965.         goto L22;
  12966.     }
  12967. /*<       EX= GX >*/
  12968.     ex.r = gx.r, ex.i = gx.i;
  12969. /*<       EY= GY >*/
  12970.     ey.r = gy.r, ey.i = gy.i;
  12971. /*<       EZ= GZ >*/
  12972.     ez.r = gz.r, ez.i = gz.i;
  12973. /*<       GOTO 25 >*/
  12974.     goto L25;
  12975. /*<    22 IF( IPERF.NE.1) GOTO 23 >*/
  12976. L22:
  12977.     if (gnd_1.iperf != 1) {
  12978.         goto L23;
  12979.     }
  12980. /*<       GX=- GX >*/
  12981.     z__1.r = -gx.r, z__1.i = -gx.i;
  12982.     gx.r = z__1.r, gx.i = z__1.i;
  12983. /*<       GY=- GY >*/
  12984.     z__1.r = -gy.r, z__1.i = -gy.i;
  12985.     gy.r = z__1.r, gy.i = z__1.i;
  12986. /*<       GZ=- GZ >*/
  12987.     z__1.r = -gz.r, z__1.i = -gz.i;
  12988.     gz.r = z__1.r, gz.i = z__1.i;
  12989. /*<       GOTO 24 >*/
  12990.     goto L24;
  12991. /*<    23 RRV= SQRT(1.- ZRATI* ZRATI* THZ* THZ) >*/
  12992. L23:
  12993.     z__5.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i * 
  12994.         gnd_1.zrati.i, z__5.i = gnd_1.zrati.r * gnd_1.zrati.i + 
  12995.         gnd_1.zrati.i * gnd_1.zrati.r;
  12996.     z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
  12997.     z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
  12998.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  12999.     z_sqrt(&z__1, &z__2);
  13000.     rrv.r = z__1.r, rrv.i = z__1.i;
  13001. /*<       RRH= ZRATI* ROZ >*/
  13002.     z__1.r = roz * gnd_1.zrati.r, z__1.i = roz * gnd_1.zrati.i;
  13003.     rrh.r = z__1.r, rrh.i = z__1.i;
  13004. /*<       RRH=( RRH- RRV)/( RRH+ RRV) >*/
  13005.     z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
  13006.     z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
  13007.     z_div(&z__1, &z__2, &z__3);
  13008.     rrh.r = z__1.r, rrh.i = z__1.i;
  13009. /*<       RRV= ZRATI* RRV >*/
  13010.     z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i = 
  13011.         gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
  13012.     rrv.r = z__1.r, rrv.i = z__1.i;
  13013. /*<       RRV=-( ROZ- RRV)/( ROZ+ RRV) >*/
  13014.     z__3.r = roz - rrv.r, z__3.i = -rrv.i;
  13015.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  13016.     z__4.r = roz + rrv.r, z__4.i = rrv.i;
  13017.     z_div(&z__1, &z__2, &z__4);
  13018.     rrv.r = z__1.r, rrv.i = z__1.i;
  13019. /*<       ETH=( GX* PHX+ GY* PHY)*( RRH- RRV) >*/
  13020.     z__3.r = phx * gx.r, z__3.i = phx * gx.i;
  13021.     z__4.r = phy * gy.r, z__4.i = phy * gy.i;
  13022.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  13023.     z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
  13024.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i 
  13025.         + z__2.i * z__5.r;
  13026.     eth->r = z__1.r, eth->i = z__1.i;
  13027. /*<       GX= GX* RRV+ ETH* PHX >*/
  13028.     z__2.r = gx.r * rrv.r - gx.i * rrv.i, z__2.i = gx.r * rrv.i + gx.i * 
  13029.         rrv.r;
  13030.     z__3.r = phx * eth->r, z__3.i = phx * eth->i;
  13031.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  13032.     gx.r = z__1.r, gx.i = z__1.i;
  13033. /*<       GY= GY* RRV+ ETH* PHY >*/
  13034.     z__2.r = gy.r * rrv.r - gy.i * rrv.i, z__2.i = gy.r * rrv.i + gy.i * 
  13035.         rrv.r;
  13036.     z__3.r = phy * eth->r, z__3.i = phy * eth->i;
  13037.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  13038.     gy.r = z__1.r, gy.i = z__1.i;
  13039. /*<       GZ= GZ* RRV >*/
  13040.     z__1.r = gz.r * rrv.r - gz.i * rrv.i, z__1.i = gz.r * rrv.i + gz.i * 
  13041.         rrv.r;
  13042.     gz.r = z__1.r, gz.i = z__1.i;
  13043. /*<    24 EX= EX+ GX >*/
  13044. L24:
  13045.     z__1.r = ex.r + gx.r, z__1.i = ex.i + gx.i;
  13046.     ex.r = z__1.r, ex.i = z__1.i;
  13047. /*<       EY= EY+ GY >*/
  13048.     z__1.r = ey.r + gy.r, z__1.i = ey.i + gy.i;
  13049.     ey.r = z__1.r, ey.i = z__1.i;
  13050. /*<       EZ= EZ- GZ >*/
  13051.     z__1.r = ez.r - gz.r, z__1.i = ez.i - gz.i;
  13052.     ez.r = z__1.r, ez.i = z__1.i;
  13053. /*<    25 CONTINUE >*/
  13054. L25:
  13055.     ;
  13056.     }
  13057. /*<       EX= EX+ CIX* CONST >*/
  13058.     z__2.r = cix.r * const_->r - cix.i * const_->i, z__2.i = cix.r * 
  13059.         const_->i + cix.i * const_->r;
  13060.     z__1.r = ex.r + z__2.r, z__1.i = ex.i + z__2.i;
  13061.     ex.r = z__1.r, ex.i = z__1.i;
  13062. /*<       EY= EY+ CIY* CONST >*/
  13063.     z__2.r = ciy.r * const_->r - ciy.i * const_->i, z__2.i = ciy.r * 
  13064.         const_->i + ciy.i * const_->r;
  13065.     z__1.r = ey.r + z__2.r, z__1.i = ey.i + z__2.i;
  13066.     ey.r = z__1.r, ey.i = z__1.i;
  13067. /*<       EZ= EZ+ CIZ* CONST >*/
  13068.     z__2.r = ciz.r * const_->r - ciz.i * const_->i, z__2.i = ciz.r * 
  13069.         const_->i + ciz.i * const_->r;
  13070.     z__1.r = ez.r + z__2.r, z__1.i = ez.i + z__2.i;
  13071.     ez.r = z__1.r, ez.i = z__1.i;
  13072. /*<       ETH= EX* THX+ EY* THY+ EZ* THZ >*/
  13073.     z__3.r = thx * ex.r, z__3.i = thx * ex.i;
  13074.     z__4.r = thy * ey.r, z__4.i = thy * ey.i;
  13075.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  13076.     z__5.r = thz * ez.r, z__5.i = thz * ez.i;
  13077.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  13078.     eth->r = z__1.r, eth->i = z__1.i;
  13079. /*<       EPH= EX* PHX+ EY* PHY >*/
  13080.     z__2.r = phx * ex.r, z__2.i = phx * ex.i;
  13081.     z__3.r = phy * ey.r, z__3.i = phy * ey.i;
  13082.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  13083.     eph->r = z__1.r, eph->i = z__1.i;
  13084. /*<       RETURN >*/
  13085.     return 0;
  13086. /*<       END >*/
  13087. } /* ffld_ */
  13088.  
  13089. #undef sab
  13090. #undef cab
  13091. #undef consx
  13092. #undef const_
  13093.  
  13094.  
  13095. /* *** */
  13096. /*     DOUBLE PRECISION 6/4/85 */
  13097.  
  13098. /*<       SUBROUTINE FFLDS( ROX, ROY, ROZ, SCUR, EX, EY, EZ) >*/
  13099. /* Subroutine */ int fflds_(rox, roy, roz, scur, ex, ey, ez)
  13100. doublereal *rox, *roy, *roz;
  13101. doublecomplex *scur, *ex, *ey, *ez;
  13102. {
  13103.     /* Initialized data */
  13104.  
  13105.     static doublereal tpi = 6.283185308;
  13106.     static struct {
  13107.     doublereal e_1[3];
  13108.     } equiv_4 = { 0., 188.365, 0. };
  13109.  
  13110.  
  13111.     /* System generated locals */
  13112.     integer i__1, i__2;
  13113.     doublereal d__1, d__2;
  13114.     doublecomplex z__1, z__2, z__3, z__4, z__5;
  13115.  
  13116.     /* Builtin functions */
  13117.     double cos(), sin();
  13118.  
  13119.     /* Local variables */
  13120. #define cons ((doublecomplex *)&equiv_4)
  13121.     static integer i, j, k;
  13122. #define s ((doublereal *)&data_1 + 2400)
  13123. #define consx ((doublereal *)&equiv_4)
  13124.     static doublecomplex ct;
  13125. #define xs ((doublereal *)&data_1)
  13126. #define ys ((doublereal *)&data_1 + 600)
  13127. #define zs ((doublereal *)&data_1 + 1200)
  13128.     static doublereal arg;
  13129.  
  13130. /* *** */
  13131. /*     CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO */
  13132. /*     SURFACE CURRENTS */
  13133. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  13134. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  13135. /*<       COMPLEX  CT, CONS, SCUR, EX, EY, EZ >*/
  13136. /*<    >*/
  13137. /*<       DIMENSION  XS(1), YS(1), ZS(1), S(1), SCUR(1), CONSX(2) >*/
  13138. /*<       EQUIVALENCE(XS,X),(YS,Y),(ZS,Z),(S,BI),(CONS,CONSX) >*/
  13139. /*<       DATA   TPI/6.283185308D+0/, CONSX/0.,188.365/ >*/
  13140.     /* Parameter adjustments */
  13141.     --scur;
  13142.  
  13143.     /* Function Body */
  13144. /*<       EX=(0.,0.) >*/
  13145.     ex->r = 0., ex->i = 0.;
  13146. /*<       EY=(0.,0.) >*/
  13147.     ey->r = 0., ey->i = 0.;
  13148. /*<       EZ=(0.,0.) >*/
  13149.     ez->r = 0., ez->i = 0.;
  13150. /*<       I= LD+1 >*/
  13151.     i = data_1.ld + 1;
  13152. /*<       DO 1  J=1, M >*/
  13153.     i__1 = data_1.m;
  13154.     for (j = 1; j <= i__1; ++j) {
  13155. /*<       I= I-1 >*/
  13156.     --i;
  13157. /*<       ARG= TPI*( ROX* XS( I)+ ROY* YS( I)+ ROZ* ZS( I)) >*/
  13158.     d__1 = *rox * xs[i - 1] + *roy * ys[i - 1];
  13159.     arg = tpi * (d__1 + *roz * zs[i - 1]);
  13160. /*<       CT= CMPLX( COS( ARG)* S( I), SIN( ARG)* S( I)) >*/
  13161.     d__1 = cos(arg) * s[i - 1];
  13162.     d__2 = sin(arg) * s[i - 1];
  13163.     z__1.r = d__1, z__1.i = d__2;
  13164.     ct.r = z__1.r, ct.i = z__1.i;
  13165. /*<       K=3* J >*/
  13166.     k = j * 3;
  13167. /*<       EX= EX+ SCUR( K-2)* CT >*/
  13168.     i__2 = k - 2;
  13169.     z__2.r = scur[i__2].r * ct.r - scur[i__2].i * ct.i, z__2.i = scur[
  13170.         i__2].r * ct.i + scur[i__2].i * ct.r;
  13171.     z__1.r = ex->r + z__2.r, z__1.i = ex->i + z__2.i;
  13172.     ex->r = z__1.r, ex->i = z__1.i;
  13173. /*<       EY= EY+ SCUR( K-1)* CT >*/
  13174.     i__2 = k - 1;
  13175.     z__2.r = scur[i__2].r * ct.r - scur[i__2].i * ct.i, z__2.i = scur[
  13176.         i__2].r * ct.i + scur[i__2].i * ct.r;
  13177.     z__1.r = ey->r + z__2.r, z__1.i = ey->i + z__2.i;
  13178.     ey->r = z__1.r, ey->i = z__1.i;
  13179. /*<       EZ= EZ+ SCUR( K)* CT >*/
  13180.     i__2 = k;
  13181.     z__2.r = scur[i__2].r * ct.r - scur[i__2].i * ct.i, z__2.i = scur[
  13182.         i__2].r * ct.i + scur[i__2].i * ct.r;
  13183.     z__1.r = ez->r + z__2.r, z__1.i = ez->i + z__2.i;
  13184.     ez->r = z__1.r, ez->i = z__1.i;
  13185. /*<     1 CONTINUE >*/
  13186. /* L1: */
  13187.     }
  13188. /*<       CT= ROX* EX+ ROY* EY+ ROZ* EZ >*/
  13189.     z__3.r = *rox * ex->r, z__3.i = *rox * ex->i;
  13190.     z__4.r = *roy * ey->r, z__4.i = *roy * ey->i;
  13191.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  13192.     z__5.r = *roz * ez->r, z__5.i = *roz * ez->i;
  13193.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  13194.     ct.r = z__1.r, ct.i = z__1.i;
  13195. /*<       EX= CONS*( CT* ROX- EX) >*/
  13196.     z__3.r = *rox * ct.r, z__3.i = *rox * ct.i;
  13197.     z__2.r = z__3.r - ex->r, z__2.i = z__3.i - ex->i;
  13198.     z__1.r = cons->r * z__2.r - cons->i * z__2.i, z__1.i = cons->r * z__2.i + 
  13199.         cons->i * z__2.r;
  13200.     ex->r = z__1.r, ex->i = z__1.i;
  13201. /*<       EY= CONS*( CT* ROY- EY) >*/
  13202.     z__3.r = *roy * ct.r, z__3.i = *roy * ct.i;
  13203.     z__2.r = z__3.r - ey->r, z__2.i = z__3.i - ey->i;
  13204.     z__1.r = cons->r * z__2.r - cons->i * z__2.i, z__1.i = cons->r * z__2.i + 
  13205.         cons->i * z__2.r;
  13206.     ey->r = z__1.r, ey->i = z__1.i;
  13207. /*<       EZ= CONS*( CT* ROZ- EZ) >*/
  13208.     z__3.r = *roz * ct.r, z__3.i = *roz * ct.i;
  13209.     z__2.r = z__3.r - ez->r, z__2.i = z__3.i - ez->i;
  13210.     z__1.r = cons->r * z__2.r - cons->i * z__2.i, z__1.i = cons->r * z__2.i + 
  13211.         cons->i * z__2.r;
  13212.     ez->r = z__1.r, ez->i = z__1.i;
  13213. /*<       RETURN >*/
  13214.     return 0;
  13215. /*<       END >*/
  13216. } /* fflds_ */
  13217.  
  13218. #undef zs
  13219. #undef ys
  13220. #undef xs
  13221. #undef consx
  13222. #undef s
  13223. #undef cons
  13224.  
  13225.  
  13226. /* *** */
  13227. /*     DOUBLE PRECISION 6/4/85 */
  13228.  
  13229. /*<       SUBROUTINE GF( ZK, CO, SI) >*/
  13230. /* Subroutine */ int gf_(zk, co, si)
  13231. doublereal *zk, *co, *si;
  13232. {
  13233.     /* Builtin functions */
  13234.     double sqrt(), sin(), cos();
  13235.  
  13236.     /* Local variables */
  13237.     static doublereal rk, zdk, rks;
  13238.  
  13239. /* *** */
  13240.  
  13241. /*     GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION. 
  13242. */
  13243.  
  13244. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  13245. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  13246. /*<       COMMON  /TMI/ ZPK, RKB2, IJ >*/
  13247. /*<       ZDK= ZK- ZPK >*/
  13248.     zdk = *zk - tmi_2.zpk;
  13249. /*<       RK= SQRT( RKB2+ ZDK* ZDK) >*/
  13250.     rk = sqrt(tmi_2.rkb2 + zdk * zdk);
  13251. /*<       SI= SIN( RK)/ RK >*/
  13252.     *si = sin(rk) / rk;
  13253. /*<       IF( IJ) 1,2,1 >*/
  13254.     if (tmi_2.ij != 0) {
  13255.     goto L1;
  13256.     } else {
  13257.     goto L2;
  13258.     }
  13259. /*<     1 CO= COS( RK)/ RK >*/
  13260. L1:
  13261.     *co = cos(rk) / rk;
  13262. /*<       RETURN >*/
  13263.     return 0;
  13264. /*<     2 IF( RK.LT..2) GOTO 3 >*/
  13265. L2:
  13266.     if (rk < .2) {
  13267.     goto L3;
  13268.     }
  13269. /*<       CO=( COS( RK)-1.)/ RK >*/
  13270.     *co = (cos(rk) - 1.) / rk;
  13271. /*<       RETURN >*/
  13272.     return 0;
  13273. /*<     3 RKS= RK* RK >*/
  13274. L3:
  13275.     rks = rk * rk;
  13276. /*<       CO=((-1.38888889D-3* RKS+4.16666667D-2)* RKS-.5)* RK >*/
  13277.     *co = ((rks * -.00138888889 + .0416666667) * rks - .5) * rk;
  13278. /*<       RETURN >*/
  13279.     return 0;
  13280. /*<       END >*/
  13281. } /* gf_ */
  13282.  
  13283. /* *** */
  13284. /*     DOUBLE PRECISION 6/4/85 */
  13285.  
  13286. /*<       SUBROUTINE GFIL( IPRT) >*/
  13287. /* Subroutine */ int gfil_(iprt)
  13288. integer *iprt;
  13289. {
  13290.     /* Initialized data */
  13291.  
  13292.     static integer igfl = 20;
  13293.  
  13294.     /* Format strings */
  13295.     static char fmt_16[] = "(////)";
  13296.     static char fmt_14[] = "(5x,\002****************************************\
  13297. **********\002,\002**********************************\002)";
  13298.     static char fmt_17[] = "(5x,\002**\002,80x,\002**\002)";
  13299.     static char fmt_18[] = "(5x,\002** NUMERICAL GREEN S FUNCTION\002,53x\
  13300. ,\002**\002,/,5x,\002** NO\002,\002. SEGMENTS =\002,i4,10x,\002NO. PATCHES \
  13301. =\002,i4,34x,\002**\002)";
  13302.     static char fmt_19[] = "(5x,\002** NO. SYMMETRIC SECTIONS =\002,i4,51x\
  13303. ,\002**\002)";
  13304.     static char fmt_20[] = "(5x,\002** N.G.F. MATRIX -  CORE STORAGE =\002,i\
  13305. 7,\002 COMPLEX NU\002,\002MBERS,  CASE\002,i2,16x,\002**\002)";
  13306.     static char fmt_21[] = "(5x,\002**\002,19x,\002MATRIX SIZE =\002,i7,\002\
  13307.  COMPLEX NUMBERS\002,25x,\002**\002)";
  13308.     static char fmt_22[] = "(5x,\002** FREQUENCY =\002,1p,e12.5,\002 MHZ.\
  13309. \002,51x,\002**\002)";
  13310.     static char fmt_23[] = "(5x,\002** PERFECT GROUND\002,65x,\002**\002)";
  13311.     static char fmt_27[] = "(5x,\002** FINITE GROUND.  REFLECTION COEFFICIEN\
  13312. T APPROXIMAT\002,\002ION\002,27x,\002**\002)";
  13313.     static char fmt_28[] = "(5x,\002** FINITE GROUND.  SOMMERFELD SOLUTIO\
  13314. N\002,44x,\002**\002)";
  13315.     static char fmt_24[] = "(5x,\002** GROUND PARAMETERS - DIELECTRIC CONSTA\
  13316. NT =\002,1p,e12.5,26x,\002**\002,/,5x,\002**\002,21x,\002CONDUCTIVITY =\002,\
  13317. e12.5,\002 MHOS/M.\002,25x,\002**\002)";
  13318.     static char fmt_15[] = "(5x,\002** \002,19a4,\002 **\002)";
  13319.     static char fmt_25[] = "(39x,\002NUMERICAL GREEN S FUNCTION DATA\002,/,4\
  13320. 1x,\002COORDINATES\002,\002 OF SEGMENT ENDS\002,/,51x,\002(METERS)\002,/,5x\
  13321. ,\002SEG.\002,11x,\002- - - END ON'E - - -\002,26x,\002- - - END TWO - - \
  13322. -\002,/,6x,\002NO.\002,6x,\002X\002,14x,\002Y\002,14x,\002Z\002,14x,\002X\
  13323. \002,14x,\002Y\002,14x,\002Z\002)";
  13324.     static char fmt_26[] = "(1x,i7,1p,6e15.6)";
  13325.  
  13326.     /* System generated locals */
  13327.     integer i__1, i__2, i__3;
  13328.     doublereal d__1;
  13329.     alist al__1;
  13330.  
  13331.     /* Builtin functions */
  13332.     integer f_rew(), s_rsue(), do_uio(), e_rsue(), s_wsue(), e_wsue(), s_wsfe(
  13333.         ), e_wsfe(), do_fio();
  13334.  
  13335.     /* Local variables */
  13336.     static integer npeq, iout, i, j, k;
  13337.     static doublereal dx, xi, yi, zi;
  13338.     extern /* Subroutine */ int blckin_(), blckot_();
  13339.     static integer neq, iop, nop, nbl2;
  13340.  
  13341.     /* Fortran I/O blocks */
  13342.     static cilist io___900 = { 0, 0, 0, 0, 0 };
  13343.     static cilist io___901 = { 0, 0, 0, 0, 0 };
  13344.     static cilist io___903 = { 0, 0, 0, 0, 0 };
  13345.     static cilist io___904 = { 0, 0, 0, 0, 0 };
  13346.     static cilist io___905 = { 0, 0, 0, 0, 0 };
  13347.     static cilist io___906 = { 0, 0, 0, 0, 0 };
  13348.     static cilist io___907 = { 0, 0, 0, 0, 0 };
  13349.     static cilist io___913 = { 0, 0, 0, 0, 0 };
  13350.     static cilist io___914 = { 0, 0, 0, 0, 0 };
  13351.     static cilist io___915 = { 0, 0, 0, 0, 0 };
  13352.     static cilist io___916 = { 0, 0, 0, 0, 0 };
  13353.     static cilist io___917 = { 0, 0, 0, 0, 0 };
  13354.     static cilist io___918 = { 0, 0, 0, 0, 0 };
  13355.     static cilist io___919 = { 0, 0, 0, 0, 0 };
  13356.     static cilist io___923 = { 0, 0, 0, 0, 0 };
  13357.     static cilist io___924 = { 0, 0, 0, 0, 0 };
  13358.     static cilist io___926 = { 0, 0, 0, 0, 0 };
  13359.     static cilist io___928 = { 0, 0, 0, 0, 0 };
  13360.     static cilist io___929 = { 0, 13, 0, 0, 0 };
  13361.     static cilist io___932 = { 0, 6, 0, fmt_16, 0 };
  13362.     static cilist io___933 = { 0, 6, 0, fmt_14, 0 };
  13363.     static cilist io___934 = { 0, 6, 0, fmt_14, 0 };
  13364.     static cilist io___935 = { 0, 6, 0, fmt_17, 0 };
  13365.     static cilist io___936 = { 0, 6, 0, fmt_18, 0 };
  13366.     static cilist io___937 = { 0, 6, 0, fmt_19, 0 };
  13367.     static cilist io___938 = { 0, 6, 0, fmt_20, 0 };
  13368.     static cilist io___939 = { 0, 6, 0, fmt_21, 0 };
  13369.     static cilist io___940 = { 0, 6, 0, fmt_22, 0 };
  13370.     static cilist io___941 = { 0, 6, 0, fmt_23, 0 };
  13371.     static cilist io___942 = { 0, 6, 0, fmt_27, 0 };
  13372.     static cilist io___943 = { 0, 6, 0, fmt_28, 0 };
  13373.     static cilist io___944 = { 0, 6, 0, fmt_24, 0 };
  13374.     static cilist io___945 = { 0, 6, 0, fmt_17, 0 };
  13375.     static cilist io___946 = { 0, 6, 0, fmt_15, 0 };
  13376.     static cilist io___947 = { 0, 6, 0, fmt_17, 0 };
  13377.     static cilist io___948 = { 0, 6, 0, fmt_14, 0 };
  13378.     static cilist io___949 = { 0, 6, 0, fmt_14, 0 };
  13379.     static cilist io___950 = { 0, 6, 0, fmt_16, 0 };
  13380.     static cilist io___951 = { 0, 6, 0, fmt_25, 0 };
  13381.     static cilist io___952 = { 0, 6, 0, fmt_26, 0 };
  13382.  
  13383.  
  13384. /* *** */
  13385.  
  13386. /*     GFIL READS THE N.G.F. FILE */
  13387.  
  13388. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  13389. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  13390. /*<    >*/
  13391. /*<    >*/
  13392. /*<       COMMON  /CMB/ CM(90000) >*/
  13393. /*<       COMMON  /ANGL/ SALP( NM) >*/
  13394. /*<    >*/
  13395. /*<    >*/
  13396. /*<    >*/
  13397. /*<       COMMON  /SMAT/ SSX(16,16) >*/
  13398. /*<       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
  13399. /*<       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
  13400. /*<       DATA   IGFL/20/ >*/
  13401. /*<       REWIND IGFL >*/
  13402.     al__1.aerr = 0;
  13403.     al__1.aunit = igfl;
  13404.     f_rew(&al__1);
  13405. /*<    >*/
  13406.     io___900.ciunit = igfl;
  13407.     s_rsue(&io___900);
  13408.     do_uio(&c__1, (char *)&data_1.n1, (ftnlen)sizeof(integer));
  13409.     do_uio(&c__1, (char *)&data_1.np, (ftnlen)sizeof(integer));
  13410.     do_uio(&c__1, (char *)&data_1.m1, (ftnlen)sizeof(integer));
  13411.     do_uio(&c__1, (char *)&data_1.mp, (ftnlen)sizeof(integer));
  13412.     do_uio(&c__1, (char *)&data_1.wlam, (ftnlen)sizeof(doublereal));
  13413.     do_uio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
  13414.     do_uio(&c__1, (char *)&data_1.ipsym, (ftnlen)sizeof(integer));
  13415.     do_uio(&c__1, (char *)&gnd_1.ksymp, (ftnlen)sizeof(integer));
  13416.     do_uio(&c__1, (char *)&gnd_1.iperf, (ftnlen)sizeof(integer));
  13417.     do_uio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
  13418.     do_uio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
  13419.     do_uio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
  13420.     do_uio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
  13421.     do_uio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
  13422.     do_uio(&c__1, (char *)&zload_1.nlodf, (ftnlen)sizeof(integer));
  13423.     do_uio(&c__1, (char *)&save_1.kcom, (ftnlen)sizeof(integer));
  13424.     e_rsue();
  13425. /*<       N= N1 >*/
  13426.     data_1.n = data_1.n1;
  13427. /*<       M= M1 >*/
  13428.     data_1.m = data_1.m1;
  13429. /*<       N2= N1+1 >*/
  13430.     data_1.n2 = data_1.n1 + 1;
  13431. /*<       M2= M1+1 >*/
  13432.     data_1.m2 = data_1.m1 + 1;
  13433. /*     READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS */
  13434.  
  13435. /*<       IF( N1.EQ.0) GOTO 2 >*/
  13436.     if (data_1.n1 == 0) {
  13437.     goto L2;
  13438.     }
  13439. /*<    >*/
  13440.     io___901.ciunit = igfl;
  13441.     s_rsue(&io___901);
  13442.     i__1 = data_1.n1;
  13443.     for (i = 1; i <= i__1; ++i) {
  13444.     do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  13445.     }
  13446.     i__2 = data_1.n1;
  13447.     for (i = 1; i <= i__2; ++i) {
  13448.     do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  13449.     }
  13450.     i__3 = data_1.n1;
  13451.     for (i = 1; i <= i__3; ++i) {
  13452.     do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  13453.     }
  13454.     e_rsue();
  13455. /*<    >*/
  13456.     io___903.ciunit = igfl;
  13457.     s_rsue(&io___903);
  13458.     i__1 = data_1.n1;
  13459.     for (i = 1; i <= i__1; ++i) {
  13460.     do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  13461.     }
  13462.     i__2 = data_1.n1;
  13463.     for (i = 1; i <= i__2; ++i) {
  13464.     do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
  13465.     }
  13466.     i__3 = data_1.n1;
  13467.     for (i = 1; i <= i__3; ++i) {
  13468.     do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
  13469.  
  13470.     }
  13471.     e_rsue();
  13472. /*<       READ( IGFL) ( BET( I), I=1, N1),( SALP( I), I=1, N1) >*/
  13473.     io___904.ciunit = igfl;
  13474.     s_rsue(&io___904);
  13475.     i__1 = data_1.n1;
  13476.     for (i = 1; i <= i__1; ++i) {
  13477.     do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
  13478.  
  13479.     }
  13480.     i__2 = data_1.n1;
  13481.     for (i = 1; i <= i__2; ++i) {
  13482.     do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
  13483.         ;
  13484.     }
  13485.     e_rsue();
  13486. /*<       READ( IGFL) ( ICON1( I), I=1, N1),( ICON2( I), I=1, N1) >*/
  13487.     io___905.ciunit = igfl;
  13488.     s_rsue(&io___905);
  13489.     i__1 = data_1.n1;
  13490.     for (i = 1; i <= i__1; ++i) {
  13491.     do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
  13492.     }
  13493.     i__2 = data_1.n1;
  13494.     for (i = 1; i <= i__2; ++i) {
  13495.     do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
  13496.     }
  13497.     e_rsue();
  13498. /*<       READ( IGFL) ( ITAG( I), I=1, N1) >*/
  13499.     io___906.ciunit = igfl;
  13500.     s_rsue(&io___906);
  13501.     i__1 = data_1.n1;
  13502.     for (i = 1; i <= i__1; ++i) {
  13503.     do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
  13504.     }
  13505.     e_rsue();
  13506. /*<       IF( NLODF.NE.0) READ( IGFL) ( ZARRAY( I), I=1, N1) >*/
  13507.     if (zload_1.nlodf != 0) {
  13508.     io___907.ciunit = igfl;
  13509.     s_rsue(&io___907);
  13510.     i__1 = data_1.n1;
  13511.     for (i = 1; i <= i__1; ++i) {
  13512.         do_uio(&c__2, (char *)&zload_1.zarray[i - 1], (ftnlen)sizeof(
  13513.             doublereal));
  13514.     }
  13515.     e_rsue();
  13516.     }
  13517. /*<       DO 1  I=1, N1 >*/
  13518.     i__1 = data_1.n1;
  13519.     for (i = 1; i <= i__1; ++i) {
  13520. /*<       XI= X( I)* WLAM >*/
  13521.     xi = data_1.x[i - 1] * data_1.wlam;
  13522. /*<       YI= Y( I)* WLAM >*/
  13523.     yi = data_1.y[i - 1] * data_1.wlam;
  13524. /*<       ZI= Z( I)* WLAM >*/
  13525.     zi = data_1.z[i - 1] * data_1.wlam;
  13526. /*<       DX= SI( I)*.5* WLAM >*/
  13527.     d__1 = data_1.si[i - 1] * .5;
  13528.     dx = d__1 * data_1.wlam;
  13529. /*<       X( I)= XI- ALP( I)* DX >*/
  13530.     data_1.x[i - 1] = xi - data_1.alp[i - 1] * dx;
  13531. /*<       Y( I)= YI- BET( I)* DX >*/
  13532.     data_1.y[i - 1] = yi - data_1.bet[i - 1] * dx;
  13533. /*<       Z( I)= ZI- SALP( I)* DX >*/
  13534.     data_1.z[i - 1] = zi - angl_1.salp[i - 1] * dx;
  13535. /*<       SI( I)= XI+ ALP( I)* DX >*/
  13536.     data_1.si[i - 1] = xi + data_1.alp[i - 1] * dx;
  13537. /*<       ALP( I)= YI+ BET( I)* DX >*/
  13538.     data_1.alp[i - 1] = yi + data_1.bet[i - 1] * dx;
  13539. /*<       BET( I)= ZI+ SALP( I)* DX >*/
  13540.     data_1.bet[i - 1] = zi + angl_1.salp[i - 1] * dx;
  13541. /*<       BI( I)= BI( I)* WLAM >*/
  13542.     data_1.bi[i - 1] *= data_1.wlam;
  13543. /*<     1 CONTINUE >*/
  13544. /* L1: */
  13545.     }
  13546. /*<     2 IF( M1.EQ.0) GOTO 4 >*/
  13547. L2:
  13548.     if (data_1.m1 == 0) {
  13549.     goto L4;
  13550.     }
  13551. /*     READ PATCH DATA AND CONVERT TO METERS */
  13552. /*<       J= LD- M1+1 >*/
  13553.     j = data_1.ld - data_1.m1 + 1;
  13554. /*<    >*/
  13555.     io___913.ciunit = igfl;
  13556.     s_rsue(&io___913);
  13557.     i__1 = data_1.ld;
  13558.     for (i = j; i <= i__1; ++i) {
  13559.     do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  13560.     }
  13561.     i__2 = data_1.ld;
  13562.     for (i = j; i <= i__2; ++i) {
  13563.     do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  13564.     }
  13565.     i__3 = data_1.ld;
  13566.     for (i = j; i <= i__3; ++i) {
  13567.     do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  13568.     }
  13569.     e_rsue();
  13570. /*<    >*/
  13571.     io___914.ciunit = igfl;
  13572.     s_rsue(&io___914);
  13573.     i__1 = data_1.ld;
  13574.     for (i = j; i <= i__1; ++i) {
  13575.     do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  13576.     }
  13577.     i__2 = data_1.ld;
  13578.     for (i = j; i <= i__2; ++i) {
  13579.     do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
  13580.     }
  13581.     i__3 = data_1.ld;
  13582.     for (i = j; i <= i__3; ++i) {
  13583.     do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
  13584.  
  13585.     }
  13586.     e_rsue();
  13587. /*<       READ( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD) >*/
  13588.     io___915.ciunit = igfl;
  13589.     s_rsue(&io___915);
  13590.     i__1 = data_1.ld;
  13591.     for (i = j; i <= i__1; ++i) {
  13592.     do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
  13593.  
  13594.     }
  13595.     i__2 = data_1.ld;
  13596.     for (i = j; i <= i__2; ++i) {
  13597.     do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
  13598.         ;
  13599.     }
  13600.     e_rsue();
  13601. /*<       READ( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD) >*/
  13602.     io___916.ciunit = igfl;
  13603.     s_rsue(&io___916);
  13604.     i__1 = data_1.ld;
  13605.     for (i = j; i <= i__1; ++i) {
  13606.     do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
  13607.     }
  13608.     i__2 = data_1.ld;
  13609.     for (i = j; i <= i__2; ++i) {
  13610.     do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
  13611.     }
  13612.     e_rsue();
  13613. /*<       READ( IGFL) ( ITAG( I), I= J, LD) >*/
  13614.     io___917.ciunit = igfl;
  13615.     s_rsue(&io___917);
  13616.     i__1 = data_1.ld;
  13617.     for (i = j; i <= i__1; ++i) {
  13618.     do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
  13619.     }
  13620.     e_rsue();
  13621. /*<       DX= WLAM* WLAM >*/
  13622.     dx = data_1.wlam * data_1.wlam;
  13623. /*<       DO 3  I= J, LD >*/
  13624.     i__1 = data_1.ld;
  13625.     for (i = j; i <= i__1; ++i) {
  13626. /*<       X( I)= X( I)* WLAM >*/
  13627.     data_1.x[i - 1] *= data_1.wlam;
  13628. /*<       Y( I)= Y( I)* WLAM >*/
  13629.     data_1.y[i - 1] *= data_1.wlam;
  13630. /*<       Z( I)= Z( I)* WLAM >*/
  13631.     data_1.z[i - 1] *= data_1.wlam;
  13632. /*<     3 BI( I)= BI( I)* DX >*/
  13633. /* L3: */
  13634.     data_1.bi[i - 1] *= dx;
  13635.     }
  13636. /*<    >*/
  13637. L4:
  13638.     io___918.ciunit = igfl;
  13639.     s_rsue(&io___918);
  13640.     do_uio(&c__1, (char *)&matpar_1.icase, (ftnlen)sizeof(integer));
  13641.     do_uio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
  13642.     do_uio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
  13643.     do_uio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
  13644.     do_uio(&c__1, (char *)&matpar_1.nblsym, (ftnlen)sizeof(integer));
  13645.     do_uio(&c__1, (char *)&matpar_1.npsym, (ftnlen)sizeof(integer));
  13646.     do_uio(&c__1, (char *)&matpar_1.nlsym, (ftnlen)sizeof(integer));
  13647.     do_uio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
  13648.     e_rsue();
  13649. /*<    >*/
  13650.     if (gnd_1.iperf == 2) {
  13651.     io___919.ciunit = igfl;
  13652.     s_rsue(&io___919);
  13653.     do_uio(&c__880, (char *)&ggrid_1.ar1[0], (ftnlen)sizeof(doublereal));
  13654.     do_uio(&c__680, (char *)&ggrid_1.ar2[0], (ftnlen)sizeof(doublereal));
  13655.     do_uio(&c__576, (char *)&ggrid_1.ar3[0], (ftnlen)sizeof(doublereal));
  13656.     do_uio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
  13657.     do_uio(&c__3, (char *)&ggrid_1.dxa[0], (ftnlen)sizeof(doublereal));
  13658.     do_uio(&c__3, (char *)&ggrid_1.dya[0], (ftnlen)sizeof(doublereal));
  13659.     do_uio(&c__3, (char *)&ggrid_1.xsa[0], (ftnlen)sizeof(doublereal));
  13660.     do_uio(&c__3, (char *)&ggrid_1.ysa[0], (ftnlen)sizeof(doublereal));
  13661.     do_uio(&c__3, (char *)&ggrid_1.nxa[0], (ftnlen)sizeof(integer));
  13662.     do_uio(&c__3, (char *)&ggrid_1.nya[0], (ftnlen)sizeof(integer));
  13663.     e_rsue();
  13664.     }
  13665. /*<       NEQ= N1+2* M1 >*/
  13666.     neq = data_1.n1 + (data_1.m1 << 1);
  13667. /*<       NPEQ= NP+2* MP >*/
  13668.     npeq = data_1.np + (data_1.mp << 1);
  13669. /*<       NOP= NEQ/ NPEQ >*/
  13670.     nop = neq / npeq;
  13671. /*<       IF( NOP.GT.1) READ( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP) >*/
  13672.     if (nop > 1) {
  13673.     io___923.ciunit = igfl;
  13674.     s_rsue(&io___923);
  13675.     i__1 = nop;
  13676.     for (j = 1; j <= i__1; ++j) {
  13677.         i__2 = nop;
  13678.         for (i = 1; i <= i__2; ++i) {
  13679.         do_uio(&c__2, (char *)&smat_1.ssx[i + (j << 4) - 17], (ftnlen)
  13680.             sizeof(doublereal));
  13681.         }
  13682.     }
  13683.     e_rsue();
  13684.     }
  13685. /*     READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE */
  13686. /*<       READ( IGFL) ( IP( I), I=1, NEQ), COM >*/
  13687.     io___924.ciunit = igfl;
  13688.     s_rsue(&io___924);
  13689.     i__2 = neq;
  13690.     for (i = 1; i <= i__2; ++i) {
  13691.     do_uio(&c__1, (char *)&save_1.ip[i - 1], (ftnlen)sizeof(integer));
  13692.     }
  13693.     do_uio(&c__95, (char *)&save_1.com[0], (ftnlen)sizeof(doublereal));
  13694.     e_rsue();
  13695. /*<       IF( ICASE.GT.2) GOTO 5 >*/
  13696.     if (matpar_1.icase > 2) {
  13697.     goto L5;
  13698.     }
  13699. /*<       IOUT= NEQ* NPEQ >*/
  13700.     iout = neq * npeq;
  13701. /*<       READ( IGFL) ( CM( I), I=1, IOUT) >*/
  13702.     io___926.ciunit = igfl;
  13703.     s_rsue(&io___926);
  13704.     i__2 = iout;
  13705.     for (i = 1; i <= i__2; ++i) {
  13706.     do_uio(&c__2, (char *)&cmb_1.cm[i - 1], (ftnlen)sizeof(doublereal));
  13707.     }
  13708.     e_rsue();
  13709. /*<       GOTO 10 >*/
  13710.     goto L10;
  13711. /*<     5 REWIND 13 >*/
  13712. L5:
  13713.     al__1.aerr = 0;
  13714.     al__1.aunit = 13;
  13715.     f_rew(&al__1);
  13716. /*<       IF( ICASE.NE.4) GOTO 7 >*/
  13717.     if (matpar_1.icase != 4) {
  13718.     goto L7;
  13719.     }
  13720. /*<       IOUT= NPEQ* NPEQ >*/
  13721.     iout = npeq * npeq;
  13722. /*<       DO 6  K=1, NOP >*/
  13723.     i__2 = nop;
  13724.     for (k = 1; k <= i__2; ++k) {
  13725. /*<       READ( IGFL) ( CM( J), J=1, IOUT) >*/
  13726.     io___928.ciunit = igfl;
  13727.     s_rsue(&io___928);
  13728.     i__1 = iout;
  13729.     for (j = 1; j <= i__1; ++j) {
  13730.         do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
  13731.             );
  13732.     }
  13733.     e_rsue();
  13734. /*<     6 WRITE( 13) ( CM( J), J=1, IOUT) >*/
  13735. /* L6: */
  13736.     s_wsue(&io___929);
  13737.     i__1 = iout;
  13738.     for (j = 1; j <= i__1; ++j) {
  13739.         do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
  13740.             );
  13741.     }
  13742.     e_wsue();
  13743.     }
  13744. /*<       GOTO 9 >*/
  13745.     goto L9;
  13746. /*<     7 IOUT= NPSYM* NPEQ*2 >*/
  13747. L7:
  13748.     iout = matpar_1.npsym * npeq << 1;
  13749. /*<       NBL2=2* NBLSYM >*/
  13750.     nbl2 = matpar_1.nblsym << 1;
  13751. /*<       DO 8  IOP=1, NOP >*/
  13752.     i__1 = nop;
  13753.     for (iop = 1; iop <= i__1; ++iop) {
  13754. /*<       DO 8  I=1, NBL2 >*/
  13755.     i__2 = nbl2;
  13756.     for (i = 1; i <= i__2; ++i) {
  13757. /*<       CALL BLCKIN( CM, IGFL,1, IOUT,1,206) >*/
  13758.         blckin_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__206);
  13759. /*<     8 CALL BLCKOT( CM,13,1, IOUT,1,205) >*/
  13760. /* L8: */
  13761.         blckot_(cmb_1.cm, &c__13, &c__1, &iout, &c__1, &c__205);
  13762.     }
  13763.     }
  13764. /*<     9 REWIND 13 >*/
  13765. L9:
  13766.     al__1.aerr = 0;
  13767.     al__1.aunit = 13;
  13768.     f_rew(&al__1);
  13769. /*     WRITE(6,N) G.F. HEADING */
  13770. /*<    10 REWIND IGFL >*/
  13771. L10:
  13772.     al__1.aerr = 0;
  13773.     al__1.aunit = igfl;
  13774.     f_rew(&al__1);
  13775. /*<       WRITE( 6,16)  >*/
  13776.     s_wsfe(&io___932);
  13777.     e_wsfe();
  13778. /*<       WRITE( 6,14)  >*/
  13779.     s_wsfe(&io___933);
  13780.     e_wsfe();
  13781. /*<       WRITE( 6,14)  >*/
  13782.     s_wsfe(&io___934);
  13783.     e_wsfe();
  13784. /*<       WRITE( 6,17)  >*/
  13785.     s_wsfe(&io___935);
  13786.     e_wsfe();
  13787. /*<       WRITE( 6,18)  N1, M1 >*/
  13788.     s_wsfe(&io___936);
  13789.     do_fio(&c__1, (char *)&data_1.n1, (ftnlen)sizeof(integer));
  13790.     do_fio(&c__1, (char *)&data_1.m1, (ftnlen)sizeof(integer));
  13791.     e_wsfe();
  13792. /*<       IF( NOP.GT.1) WRITE( 6,19)  NOP >*/
  13793.     if (nop > 1) {
  13794.     s_wsfe(&io___937);
  13795.     do_fio(&c__1, (char *)&nop, (ftnlen)sizeof(integer));
  13796.     e_wsfe();
  13797.     }
  13798. /*<       WRITE( 6,20)  IMAT, ICASE >*/
  13799.     s_wsfe(&io___938);
  13800.     do_fio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
  13801.     do_fio(&c__1, (char *)&matpar_1.icase, (ftnlen)sizeof(integer));
  13802.     e_wsfe();
  13803. /*<       IF( ICASE.LT.3) GOTO 11 >*/
  13804.     if (matpar_1.icase < 3) {
  13805.     goto L11;
  13806.     }
  13807. /*<       NBL2= NEQ* NPEQ >*/
  13808.     nbl2 = neq * npeq;
  13809. /*<       WRITE( 6,21)  NBL2 >*/
  13810.     s_wsfe(&io___939);
  13811.     do_fio(&c__1, (char *)&nbl2, (ftnlen)sizeof(integer));
  13812.     e_wsfe();
  13813. /*<    11 WRITE( 6,22)  FMHZ >*/
  13814. L11:
  13815.     s_wsfe(&io___940);
  13816.     do_fio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
  13817.     e_wsfe();
  13818. /*<       IF( KSYMP.EQ.2.AND. IPERF.EQ.1) WRITE( 6,23)  >*/
  13819.     if (gnd_1.ksymp == 2 && gnd_1.iperf == 1) {
  13820.     s_wsfe(&io___941);
  13821.     e_wsfe();
  13822.     }
  13823. /*<       IF( KSYMP.EQ.2.AND. IPERF.EQ.0) WRITE( 6,27)  >*/
  13824.     if (gnd_1.ksymp == 2 && gnd_1.iperf == 0) {
  13825.     s_wsfe(&io___942);
  13826.     e_wsfe();
  13827.     }
  13828. /*<       IF( KSYMP.EQ.2.AND. IPERF.EQ.2) WRITE( 6,28)  >*/
  13829.     if (gnd_1.ksymp == 2 && gnd_1.iperf == 2) {
  13830.     s_wsfe(&io___943);
  13831.     e_wsfe();
  13832.     }
  13833. /*<       IF( KSYMP.EQ.2.AND. IPERF.NE.1) WRITE( 6,24)  EPSR, SIG >*/
  13834.     if (gnd_1.ksymp == 2 && gnd_1.iperf != 1) {
  13835.     s_wsfe(&io___944);
  13836.     do_fio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
  13837.     do_fio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
  13838.     e_wsfe();
  13839.     }
  13840. /*<       WRITE( 6,17)  >*/
  13841.     s_wsfe(&io___945);
  13842.     e_wsfe();
  13843. /*<       DO 12  J=1, KCOM >*/
  13844.     i__2 = save_1.kcom;
  13845.     for (j = 1; j <= i__2; ++j) {
  13846. /*<    12 WRITE( 6,15) ( COM( I, J), I=1,19) >*/
  13847. /* L12: */
  13848.     s_wsfe(&io___946);
  13849.     for (i = 1; i <= 19; ++i) {
  13850.         do_fio(&c__1, (char *)&save_1.com[i + j * 19 - 20], (ftnlen)
  13851.             sizeof(doublereal));
  13852.     }
  13853.     e_wsfe();
  13854.     }
  13855. /*<       WRITE( 6,17)  >*/
  13856.     s_wsfe(&io___947);
  13857.     e_wsfe();
  13858. /*<       WRITE( 6,14)  >*/
  13859.     s_wsfe(&io___948);
  13860.     e_wsfe();
  13861. /*<       WRITE( 6,14)  >*/
  13862.     s_wsfe(&io___949);
  13863.     e_wsfe();
  13864. /*<       WRITE( 6,16)  >*/
  13865.     s_wsfe(&io___950);
  13866.     e_wsfe();
  13867. /*<       IF( IPRT.EQ.0) RETURN >*/
  13868.     if (*iprt == 0) {
  13869.     return 0;
  13870.     }
  13871. /*<       WRITE( 6,25)  >*/
  13872.     s_wsfe(&io___951);
  13873.     e_wsfe();
  13874. /*<       DO 13  I=1, N1 >*/
  13875.     i__2 = data_1.n1;
  13876.     for (i = 1; i <= i__2; ++i) {
  13877. /*<    13 WRITE( 6,26)  I, X( I), Y( I), Z( I), SI( I), ALP( I), BET( I) >*/
  13878. /* L13: */
  13879.     s_wsfe(&io___952);
  13880.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  13881.     do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  13882.     do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  13883.     do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  13884.     do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  13885.     do_fio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
  13886.  
  13887.     do_fio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
  13888.  
  13889.     e_wsfe();
  13890.     }
  13891.  
  13892. /*<       RETURN >*/
  13893.     return 0;
  13894. /*<    >*/
  13895. /*<    15 FORMAT(5X,3H** ,19A4,3H **) >*/
  13896. /*<    16 FORMAT(////) >*/
  13897. /*<    17 FORMAT(5X,2H**,80X,2H**) >*/
  13898. /*<    >*/
  13899. /*<    19 FORMAT(5X,'** NO. SYMMETRIC SECTIONS =',I4,51X,2H**) >*/
  13900. /*<    >*/
  13901. /*<    21 FORMAT(5X,2H**,19X,'MATRIX SIZE =',I7,' COMPLEX NUMBERS',25X,'**') >*/
  13902. /*<    22 FORMAT(5X,'** FREQUENCY =',1P,E12.5,' MHZ.',51X,2H**) >*/
  13903. /*<    23 FORMAT(5X,'** PERFECT GROUND',65X,2H**) >*/
  13904. /*<    >*/
  13905. /*<    >*/
  13906. /*<    26 FORMAT(1X,I7,1P,6E15.6) >*/
  13907. /*<    >*/
  13908. /*<    28 FORMAT(5X,'** FINITE GROUND.  SOMMERFELD SOLUTION',44X,'**') >*/
  13909. /*<       END >*/
  13910. } /* gfil_ */
  13911.  
  13912. /* *** */
  13913. /*     DOUBLE PRECISION 6/4/85 */
  13914.  
  13915. /*<       SUBROUTINE GFLD( RHO, PHI, RZ, ETH, EPI, ERD, UX, KSYMP) >*/
  13916. /* Subroutine */ int gfld_(rho, phi, rz, eth, epi, erd, ux, ksymp)
  13917. doublereal *rho, *phi, *rz;
  13918. doublecomplex *eth, *epi, *erd, *ux;
  13919. integer *ksymp;
  13920. {
  13921.     /* Initialized data */
  13922.  
  13923.     static doublereal pi = 3.141592654;
  13924.     static doublereal tp = 6.283185308;
  13925.  
  13926.     /* System generated locals */
  13927.     integer i__1;
  13928.     doublereal d__1, d__2;
  13929.     doublecomplex z__1, z__2, z__3, z__4, z__5;
  13930.  
  13931.     /* Builtin functions */
  13932.     double sqrt(), z_abs(), atan(), cos(), sin();
  13933.  
  13934.     /* Local variables */
  13935.     extern /* Subroutine */ int ffld_();
  13936.     static doublereal cbet, calp, sbet, sill, thet, rxyz, a, b, c;
  13937.     static integer i, k;
  13938.     static doublereal r, omega;
  13939.     extern /* Subroutine */ int gwave_();
  13940.     static doublereal el;
  13941.     static doublecomplex ex, ey;
  13942.     static doublereal dx, dy, dz, rr, ri, rx, ry;
  13943. #define cab ((doublereal *)&data_1 + 3000)
  13944. #define sab ((doublereal *)&data_1 + 3600)
  13945.     static doublereal arg;
  13946.     static doublecomplex eph, exa, erh, cix, ciy, ciz, ezh, erv;
  13947.     static doublereal phx, phy, rix;
  13948.     static doublecomplex ezv;
  13949.     static doublereal riy, rhs, rhp, rhx, rhy, cph, sph, rfl, riz, rnx, rny, 
  13950.         rnz, top, bot, too, boo, thx, thy, thz;
  13951.  
  13952. /* *** */
  13953.  
  13954. /*     GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE. */
  13955.  
  13956. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  13957. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  13958. /*<    >*/
  13959. /*<       COMPLEX  EZH, EX, EY, ETH, UX, ERD >*/
  13960. /*<    >*/
  13961. /*<       COMMON  /ANGL/ SALP( NM) >*/
  13962. /*<    >*/
  13963. /*<       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
  13964. /*<       DIMENSION  CAB(1), SAB(1) >*/
  13965. /*<       EQUIVALENCE(CAB(1),ALP(1)),(SAB(1),BET(1)) >*/
  13966. /*<       DATA   PI, TP/3.141592654D+0,6.283185308D+0/ >*/
  13967. /*<       R= SQRT( RHO* RHO+ RZ* RZ) >*/
  13968.     r = sqrt(*rho * *rho + *rz * *rz);
  13969. /*<       IF( KSYMP.EQ.1) GOTO 1 >*/
  13970.     if (*ksymp == 1) {
  13971.     goto L1;
  13972.     }
  13973. /*<       IF( ABS( UX).GT..5) GOTO 1 >*/
  13974.     if (z_abs(ux) > .5) {
  13975.     goto L1;
  13976.     }
  13977. /*<       IF( R.GT.1.E5) GOTO 1 >*/
  13978.     if (r > 1e5) {
  13979.     goto L1;
  13980.     }
  13981.  
  13982. /*     COMPUTATION OF SPACE WAVE ONLY */
  13983.  
  13984. /*<       GOTO 4 >*/
  13985.     goto L4;
  13986. /*<     1 IF( RZ.LT.1.D-20) GOTO 2 >*/
  13987. L1:
  13988.     if (*rz < 1e-20) {
  13989.     goto L2;
  13990.     }
  13991. /*<       THET= ATAN( RHO/ RZ) >*/
  13992.     thet = atan(*rho / *rz);
  13993. /*<       GOTO 3 >*/
  13994.     goto L3;
  13995. /*<     2 THET= PI*.5 >*/
  13996. L2:
  13997.     thet = pi * .5;
  13998. /*<     3 CALL FFLD( THET, PHI, ETH, EPI) >*/
  13999. L3:
  14000.     ffld_(&thet, phi, eth, epi);
  14001. /*<       ARG=- TP* R >*/
  14002.     arg = -tp * r;
  14003. /*<       EXA= CMPLX( COS( ARG), SIN( ARG))/ R >*/
  14004.     d__1 = cos(arg);
  14005.     d__2 = sin(arg);
  14006.     z__2.r = d__1, z__2.i = d__2;
  14007.     z__1.r = z__2.r / r, z__1.i = z__2.i / r;
  14008.     exa.r = z__1.r, exa.i = z__1.i;
  14009. /*<       ETH= ETH* EXA >*/
  14010.     z__1.r = eth->r * exa.r - eth->i * exa.i, z__1.i = eth->r * exa.i + 
  14011.         eth->i * exa.r;
  14012.     eth->r = z__1.r, eth->i = z__1.i;
  14013. /*<       EPI= EPI* EXA >*/
  14014.     z__1.r = epi->r * exa.r - epi->i * exa.i, z__1.i = epi->r * exa.i + 
  14015.         epi->i * exa.r;
  14016.     epi->r = z__1.r, epi->i = z__1.i;
  14017. /*<       ERD=(0.,0.) >*/
  14018.     erd->r = 0., erd->i = 0.;
  14019.  
  14020. /*     COMPUTATION OF SPACE AND GROUND WAVES. */
  14021.  
  14022. /*<       RETURN >*/
  14023.     return 0;
  14024. /*<     4 U= UX >*/
  14025. L4:
  14026.     gwav_1.u.r = ux->r, gwav_1.u.i = ux->i;
  14027. /*<       U2= U* U >*/
  14028.     z__1.r = gwav_1.u.r * gwav_1.u.r - gwav_1.u.i * gwav_1.u.i, z__1.i = 
  14029.         gwav_1.u.r * gwav_1.u.i + gwav_1.u.i * gwav_1.u.r;
  14030.     gwav_1.u2.r = z__1.r, gwav_1.u2.i = z__1.i;
  14031. /*<       PHX=- SIN( PHI) >*/
  14032.     phx = -sin(*phi);
  14033. /*<       PHY= COS( PHI) >*/
  14034.     phy = cos(*phi);
  14035. /*<       RX= RHO* PHY >*/
  14036.     rx = *rho * phy;
  14037. /*<       RY=- RHO* PHX >*/
  14038.     ry = -(*rho) * phx;
  14039. /*<       CIX=(0.,0.) >*/
  14040.     cix.r = 0., cix.i = 0.;
  14041. /*<       CIY=(0.,0.) >*/
  14042.     ciy.r = 0., ciy.i = 0.;
  14043.  
  14044. /*     SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS */
  14045.  
  14046. /*<       CIZ=(0.,0.) >*/
  14047.     ciz.r = 0., ciz.i = 0.;
  14048. /*<       DO 17  I=1, N >*/
  14049.     i__1 = data_1.n;
  14050.     for (i = 1; i <= i__1; ++i) {
  14051. /*<       DX= CAB( I) >*/
  14052.     dx = cab[i - 1];
  14053. /*<       DY= SAB( I) >*/
  14054.     dy = sab[i - 1];
  14055. /*<       DZ= SALP( I) >*/
  14056.     dz = angl_1.salp[i - 1];
  14057. /*<       RIX= RX- X( I) >*/
  14058.     rix = rx - data_1.x[i - 1];
  14059. /*<       RIY= RY- Y( I) >*/
  14060.     riy = ry - data_1.y[i - 1];
  14061. /*<       RHS= RIX* RIX+ RIY* RIY >*/
  14062.     rhs = rix * rix + riy * riy;
  14063. /*<       RHP= SQRT( RHS) >*/
  14064.     rhp = sqrt(rhs);
  14065. /*<       IF( RHP.LT.1.D-6) GOTO 5 >*/
  14066.     if (rhp < 1e-6) {
  14067.         goto L5;
  14068.     }
  14069. /*<       RHX= RIX/ RHP >*/
  14070.     rhx = rix / rhp;
  14071. /*<       RHY= RIY/ RHP >*/
  14072.     rhy = riy / rhp;
  14073. /*<       GOTO 6 >*/
  14074.     goto L6;
  14075. /*<     5 RHX=1. >*/
  14076. L5:
  14077.     rhx = 1.;
  14078. /*<       RHY=0. >*/
  14079.     rhy = 0.;
  14080. /*<     6 CALP=1.- DZ* DZ >*/
  14081. L6:
  14082.     calp = 1. - dz * dz;
  14083. /*<       IF( CALP.LT.1.D-6) GOTO 7 >*/
  14084.     if (calp < 1e-6) {
  14085.         goto L7;
  14086.     }
  14087. /*<       CALP= SQRT( CALP) >*/
  14088.     calp = sqrt(calp);
  14089. /*<       CBET= DX/ CALP >*/
  14090.     cbet = dx / calp;
  14091. /*<       SBET= DY/ CALP >*/
  14092.     sbet = dy / calp;
  14093. /*<       CPH= RHX* CBET+ RHY* SBET >*/
  14094.     cph = rhx * cbet + rhy * sbet;
  14095. /*<       SPH= RHY* CBET- RHX* SBET >*/
  14096.     sph = rhy * cbet - rhx * sbet;
  14097. /*<       GOTO 8 >*/
  14098.     goto L8;
  14099. /*<     7 CPH= RHX >*/
  14100. L7:
  14101.     cph = rhx;
  14102. /*<       SPH= RHY >*/
  14103.     sph = rhy;
  14104. /*<     8 EL= PI* SI( I) >*/
  14105. L8:
  14106.     el = pi * data_1.si[i - 1];
  14107.  
  14108. /*     INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE 
  14109. FOR */
  14110. /*     CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS */
  14111.  
  14112. /*<       RFL=-1. >*/
  14113.     rfl = -1.;
  14114. /*<       DO 16  K=1,2 >*/
  14115.     for (k = 1; k <= 2; ++k) {
  14116. /*<       RFL=- RFL >*/
  14117.         rfl = -rfl;
  14118. /*<       RIZ= RZ- Z( I)* RFL >*/
  14119.         riz = *rz - data_1.z[i - 1] * rfl;
  14120. /*<       RXYZ= SQRT( RIX* RIX+ RIY* RIY+ RIZ* RIZ) >*/
  14121.         d__1 = rix * rix + riy * riy;
  14122.         rxyz = sqrt(d__1 + riz * riz);
  14123. /*<       RNX= RIX/ RXYZ >*/
  14124.         rnx = rix / rxyz;
  14125. /*<       RNY= RIY/ RXYZ >*/
  14126.         rny = riy / rxyz;
  14127. /*<       RNZ= RIZ/ RXYZ >*/
  14128.         rnz = riz / rxyz;
  14129. /*<       OMEGA=-( RNX* DX+ RNY* DY+ RNZ* DZ* RFL) >*/
  14130.         d__1 = rnx * dx + rny * dy;
  14131.         d__2 = rnz * dz;
  14132.         omega = -(d__1 + d__2 * rfl);
  14133. /*<       SILL= OMEGA* EL >*/
  14134.         sill = omega * el;
  14135. /*<       TOP= EL+ SILL >*/
  14136.         top = el + sill;
  14137. /*<       BOT= EL- SILL >*/
  14138.         bot = el - sill;
  14139. /*<       IF( ABS( OMEGA).LT.1.D-7) GOTO 9 >*/
  14140.         if (abs(omega) < 1e-7) {
  14141.         goto L9;
  14142.         }
  14143. /*<       A=2.* SIN( SILL)/ OMEGA >*/
  14144.         a = sin(sill) * 2. / omega;
  14145. /*<       GOTO 10 >*/
  14146.         goto L10;
  14147. /*<     9 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL >*/
  14148. L9:
  14149.         d__2 = omega * omega;
  14150.         d__1 = d__2 * el;
  14151.         a = (2. - d__1 * el / 3.) * el;
  14152. /*<    10 IF( ABS( TOP).LT.1.D-7) GOTO 11 >*/
  14153. L10:
  14154.         if (abs(top) < 1e-7) {
  14155.         goto L11;
  14156.         }
  14157. /*<       TOO= SIN( TOP)/ TOP >*/
  14158.         too = sin(top) / top;
  14159. /*<       GOTO 12 >*/
  14160.         goto L12;
  14161. /*<    11 TOO=1.- TOP* TOP/6. >*/
  14162. L11:
  14163.         too = 1. - top * top / 6.;
  14164. /*<    12 IF( ABS( BOT).LT.1.D-7) GOTO 13 >*/
  14165. L12:
  14166.         if (abs(bot) < 1e-7) {
  14167.         goto L13;
  14168.         }
  14169. /*<       BOO= SIN( BOT)/ BOT >*/
  14170.         boo = sin(bot) / bot;
  14171. /*<       GOTO 14 >*/
  14172.         goto L14;
  14173. /*<    13 BOO=1.- BOT* BOT/6. >*/
  14174. L13:
  14175.         boo = 1. - bot * bot / 6.;
  14176. /*<    14 B= EL*( BOO- TOO) >*/
  14177. L14:
  14178.         b = el * (boo - too);
  14179. /*<       C= EL*( BOO+ TOO) >*/
  14180.         c = el * (boo + too);
  14181. /*<       RR= A* AIR( I)+ B* BII( I)+ C* CIR( I) >*/
  14182.         d__1 = a * crnt_1.air[i - 1] + b * crnt_1.bii[i - 1];
  14183.         rr = d__1 + c * crnt_1.cir[i - 1];
  14184. /*<       RI= A* AII( I)- B* BIR( I)+ C* CII( I) >*/
  14185.         ri = a * crnt_1.aii[i - 1] - b * crnt_1.bir[i - 1] + c * 
  14186.             crnt_1.cii[i - 1];
  14187. /*<       ARG= TP*( X( I)* RNX+ Y( I)* RNY+ Z( I)* RNZ* RFL) >*/
  14188.         d__1 = data_1.x[i - 1] * rnx + data_1.y[i - 1] * rny;
  14189.         d__2 = data_1.z[i - 1] * rnz;
  14190.         arg = tp * (d__1 + d__2 * rfl);
  14191. /*<       EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)/ TP >*/
  14192.         d__1 = cos(arg);
  14193.         d__2 = sin(arg);
  14194.         z__3.r = d__1, z__3.i = d__2;
  14195.         z__4.r = rr, z__4.i = ri;
  14196.         z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * 
  14197.             z__4.i + z__3.i * z__4.r;
  14198.         z__1.r = z__2.r / tp, z__1.i = z__2.i / tp;
  14199.         exa.r = z__1.r, exa.i = z__1.i;
  14200. /*<       IF( K.EQ.2) GOTO 15 >*/
  14201.         if (k == 2) {
  14202.         goto L15;
  14203.         }
  14204. /*<       XX1= EXA >*/
  14205.         gwav_1.xx1.r = exa.r, gwav_1.xx1.i = exa.i;
  14206. /*<       R1= RXYZ >*/
  14207.         gwav_1.r1 = rxyz;
  14208. /*<       ZMH= RIZ >*/
  14209.         gwav_1.zmh = riz;
  14210. /*<       GOTO 16 >*/
  14211.         goto L16;
  14212. /*<    15 XX2= EXA >*/
  14213. L15:
  14214.         gwav_1.xx2.r = exa.r, gwav_1.xx2.i = exa.i;
  14215. /*<       R2= RXYZ >*/
  14216.         gwav_1.r2 = rxyz;
  14217. /*<       ZPH= RIZ >*/
  14218.         gwav_1.zph = riz;
  14219.  
  14220. /*     CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING G
  14221. ROUND */
  14222. /*     WAVE. */
  14223.  
  14224. /*<    16 CONTINUE >*/
  14225. L16:
  14226.         ;
  14227.     }
  14228. /*<       CALL GWAVE( ERV, EZV, ERH, EZH, EPH) >*/
  14229.     gwave_(&erv, &ezv, &erh, &ezh, &eph);
  14230. /*<       ERH= ERH* CPH* CALP+ ERV* DZ >*/
  14231.     z__3.r = cph * erh.r, z__3.i = cph * erh.i;
  14232.     z__2.r = calp * z__3.r, z__2.i = calp * z__3.i;
  14233.     z__4.r = dz * erv.r, z__4.i = dz * erv.i;
  14234.     z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  14235.     erh.r = z__1.r, erh.i = z__1.i;
  14236. /*<       EPH= EPH* SPH* CALP >*/
  14237.     z__2.r = sph * eph.r, z__2.i = sph * eph.i;
  14238.     z__1.r = calp * z__2.r, z__1.i = calp * z__2.i;
  14239.     eph.r = z__1.r, eph.i = z__1.i;
  14240. /*<       EZH= EZH* CPH* CALP+ EZV* DZ >*/
  14241.     z__3.r = cph * ezh.r, z__3.i = cph * ezh.i;
  14242.     z__2.r = calp * z__3.r, z__2.i = calp * z__3.i;
  14243.     z__4.r = dz * ezv.r, z__4.i = dz * ezv.i;
  14244.     z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  14245.     ezh.r = z__1.r, ezh.i = z__1.i;
  14246. /*<       EX= ERH* RHX- EPH* RHY >*/
  14247.     z__2.r = rhx * erh.r, z__2.i = rhx * erh.i;
  14248.     z__3.r = rhy * eph.r, z__3.i = rhy * eph.i;
  14249.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  14250.     ex.r = z__1.r, ex.i = z__1.i;
  14251. /*<       EY= ERH* RHY+ EPH* RHX >*/
  14252.     z__2.r = rhy * erh.r, z__2.i = rhy * erh.i;
  14253.     z__3.r = rhx * eph.r, z__3.i = rhx * eph.i;
  14254.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  14255.     ey.r = z__1.r, ey.i = z__1.i;
  14256. /*<       CIX= CIX+ EX >*/
  14257.     z__1.r = cix.r + ex.r, z__1.i = cix.i + ex.i;
  14258.     cix.r = z__1.r, cix.i = z__1.i;
  14259. /*<       CIY= CIY+ EY >*/
  14260.     z__1.r = ciy.r + ey.r, z__1.i = ciy.i + ey.i;
  14261.     ciy.r = z__1.r, ciy.i = z__1.i;
  14262. /*<    17 CIZ= CIZ+ EZH >*/
  14263. /* L17: */
  14264.     z__1.r = ciz.r + ezh.r, z__1.i = ciz.i + ezh.i;
  14265.     ciz.r = z__1.r, ciz.i = z__1.i;
  14266.     }
  14267. /*<       ARG=- TP* R >*/
  14268.     arg = -tp * r;
  14269. /*<       EXA= CMPLX( COS( ARG), SIN( ARG)) >*/
  14270.     d__1 = cos(arg);
  14271.     d__2 = sin(arg);
  14272.     z__1.r = d__1, z__1.i = d__2;
  14273.     exa.r = z__1.r, exa.i = z__1.i;
  14274. /*<       CIX= CIX* EXA >*/
  14275.     z__1.r = cix.r * exa.r - cix.i * exa.i, z__1.i = cix.r * exa.i + cix.i * 
  14276.         exa.r;
  14277.     cix.r = z__1.r, cix.i = z__1.i;
  14278. /*<       CIY= CIY* EXA >*/
  14279.     z__1.r = ciy.r * exa.r - ciy.i * exa.i, z__1.i = ciy.r * exa.i + ciy.i * 
  14280.         exa.r;
  14281.     ciy.r = z__1.r, ciy.i = z__1.i;
  14282. /*<       CIZ= CIZ* EXA >*/
  14283.     z__1.r = ciz.r * exa.r - ciz.i * exa.i, z__1.i = ciz.r * exa.i + ciz.i * 
  14284.         exa.r;
  14285.     ciz.r = z__1.r, ciz.i = z__1.i;
  14286. /*<       RNX= RX/ R >*/
  14287.     rnx = rx / r;
  14288. /*<       RNY= RY/ R >*/
  14289.     rny = ry / r;
  14290. /*<       RNZ= RZ/ R >*/
  14291.     rnz = *rz / r;
  14292. /*<       THX= RNZ* PHY >*/
  14293.     thx = rnz * phy;
  14294. /*<       THY=- RNZ* PHX >*/
  14295.     thy = -rnz * phx;
  14296. /*<       THZ=- RHO/ R >*/
  14297.     thz = -(*rho) / r;
  14298. /*<       ETH= CIX* THX+ CIY* THY+ CIZ* THZ >*/
  14299.     z__3.r = thx * cix.r, z__3.i = thx * cix.i;
  14300.     z__4.r = thy * ciy.r, z__4.i = thy * ciy.i;
  14301.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  14302.     z__5.r = thz * ciz.r, z__5.i = thz * ciz.i;
  14303.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  14304.     eth->r = z__1.r, eth->i = z__1.i;
  14305. /*<       EPI= CIX* PHX+ CIY* PHY >*/
  14306.     z__2.r = phx * cix.r, z__2.i = phx * cix.i;
  14307.     z__3.r = phy * ciy.r, z__3.i = phy * ciy.i;
  14308.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  14309.     epi->r = z__1.r, epi->i = z__1.i;
  14310. /*<       ERD= CIX* RNX+ CIY* RNY+ CIZ* RNZ >*/
  14311.     z__3.r = rnx * cix.r, z__3.i = rnx * cix.i;
  14312.     z__4.r = rny * ciy.r, z__4.i = rny * ciy.i;
  14313.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  14314.     z__5.r = rnz * ciz.r, z__5.i = rnz * ciz.i;
  14315.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  14316.     erd->r = z__1.r, erd->i = z__1.i;
  14317. /*<       RETURN >*/
  14318.     return 0;
  14319. /*<       END >*/
  14320. } /* gfld_ */
  14321.  
  14322. #undef sab
  14323. #undef cab
  14324.  
  14325.  
  14326. /* *** */
  14327. /*     DOUBLE PRECISION 6/4/85 */
  14328.  
  14329. /*<       SUBROUTINE GFOUT >*/
  14330. /* Subroutine */ int gfout_()
  14331. {
  14332.     /* Initialized data */
  14333.  
  14334.     static integer igfl = 20;
  14335.  
  14336.     /* Format strings */
  14337.     static char fmt_13[] = "(///,\002 ****NUMERICAL GREEN S FUNCTION FILE ON\
  14338.  TAPE\002,i3,\002****\002,/,5x,\002MATRIX STORAGE -\002,i7,\002 COMPLEX NUMB\
  14339. ERS\002,///)";
  14340.  
  14341.     /* System generated locals */
  14342.     integer i__1, i__2, i__3;
  14343.     alist al__1;
  14344.  
  14345.     /* Builtin functions */
  14346.     integer s_wsue(), do_uio(), e_wsue(), f_rew(), s_rsue(), e_rsue(), s_wsfe(
  14347.         ), do_fio(), e_wsfe();
  14348.  
  14349.     /* Local variables */
  14350.     static integer npeq, iout, i, j, k;
  14351.     extern /* Subroutine */ int blckin_(), blckot_();
  14352.     static integer neq, iop, nop;
  14353.  
  14354.     /* Fortran I/O blocks */
  14355.     static cilist io___1016 = { 0, 0, 0, 0, 0 };
  14356.     static cilist io___1017 = { 0, 0, 0, 0, 0 };
  14357.     static cilist io___1019 = { 0, 0, 0, 0, 0 };
  14358.     static cilist io___1020 = { 0, 0, 0, 0, 0 };
  14359.     static cilist io___1021 = { 0, 0, 0, 0, 0 };
  14360.     static cilist io___1022 = { 0, 0, 0, 0, 0 };
  14361.     static cilist io___1023 = { 0, 0, 0, 0, 0 };
  14362.     static cilist io___1025 = { 0, 0, 0, 0, 0 };
  14363.     static cilist io___1026 = { 0, 0, 0, 0, 0 };
  14364.     static cilist io___1027 = { 0, 0, 0, 0, 0 };
  14365.     static cilist io___1028 = { 0, 0, 0, 0, 0 };
  14366.     static cilist io___1029 = { 0, 0, 0, 0, 0 };
  14367.     static cilist io___1030 = { 0, 0, 0, 0, 0 };
  14368.     static cilist io___1031 = { 0, 0, 0, 0, 0 };
  14369.     static cilist io___1032 = { 0, 0, 0, 0, 0 };
  14370.     static cilist io___1033 = { 0, 0, 0, 0, 0 };
  14371.     static cilist io___1035 = { 0, 0, 0, 0, 0 };
  14372.     static cilist io___1037 = { 0, 13, 0, 0, 0 };
  14373.     static cilist io___1038 = { 0, 0, 0, 0, 0 };
  14374.     static cilist io___1040 = { 0, 6, 0, fmt_13, 0 };
  14375.  
  14376.  
  14377. /* *** */
  14378.  
  14379. /*     WRITE N.G.F. FILE */
  14380.  
  14381. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  14382. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  14383. /*<    >*/
  14384. /*<    >*/
  14385. /*<       COMMON  /CMB/ CM(90000) >*/
  14386. /*<       COMMON  /ANGL/ SALP( NM) >*/
  14387. /*<    >*/
  14388. /*<    >*/
  14389. /*<    >*/
  14390. /*<       COMMON  /SMAT/ SSX(16,16) >*/
  14391. /*<       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
  14392. /*<       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
  14393. /*<       DATA   IGFL/20/ >*/
  14394. /*<       NEQ= N+2* M >*/
  14395.     neq = data_1.n + (data_1.m << 1);
  14396. /*<       NPEQ= NP+2* MP >*/
  14397.     npeq = data_1.np + (data_1.mp << 1);
  14398. /*<       NOP= NEQ/ NPEQ >*/
  14399.     nop = neq / npeq;
  14400. /*<    >*/
  14401.     io___1016.ciunit = igfl;
  14402.     s_wsue(&io___1016);
  14403.     do_uio(&c__1, (char *)&data_1.n, (ftnlen)sizeof(integer));
  14404.     do_uio(&c__1, (char *)&data_1.np, (ftnlen)sizeof(integer));
  14405.     do_uio(&c__1, (char *)&data_1.m, (ftnlen)sizeof(integer));
  14406.     do_uio(&c__1, (char *)&data_1.mp, (ftnlen)sizeof(integer));
  14407.     do_uio(&c__1, (char *)&data_1.wlam, (ftnlen)sizeof(doublereal));
  14408.     do_uio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
  14409.     do_uio(&c__1, (char *)&data_1.ipsym, (ftnlen)sizeof(integer));
  14410.     do_uio(&c__1, (char *)&gnd_1.ksymp, (ftnlen)sizeof(integer));
  14411.     do_uio(&c__1, (char *)&gnd_1.iperf, (ftnlen)sizeof(integer));
  14412.     do_uio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
  14413.     do_uio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
  14414.     do_uio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
  14415.     do_uio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
  14416.     do_uio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
  14417.     do_uio(&c__1, (char *)&zload_1.nload, (ftnlen)sizeof(integer));
  14418.     do_uio(&c__1, (char *)&save_1.kcom, (ftnlen)sizeof(integer));
  14419.     e_wsue();
  14420. /*<       IF( N.EQ.0) GOTO 1 >*/
  14421.     if (data_1.n == 0) {
  14422.     goto L1;
  14423.     }
  14424. /*<       WRITE( IGFL) ( X( I), I=1, N),( Y( I), I=1, N),( Z( I), I=1, N) >*/
  14425.     io___1017.ciunit = igfl;
  14426.     s_wsue(&io___1017);
  14427.     i__1 = data_1.n;
  14428.     for (i = 1; i <= i__1; ++i) {
  14429.     do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  14430.     }
  14431.     i__2 = data_1.n;
  14432.     for (i = 1; i <= i__2; ++i) {
  14433.     do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  14434.     }
  14435.     i__3 = data_1.n;
  14436.     for (i = 1; i <= i__3; ++i) {
  14437.     do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  14438.     }
  14439.     e_wsue();
  14440. /*<    >*/
  14441.     io___1019.ciunit = igfl;
  14442.     s_wsue(&io___1019);
  14443.     i__1 = data_1.n;
  14444.     for (i = 1; i <= i__1; ++i) {
  14445.     do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  14446.     }
  14447.     i__2 = data_1.n;
  14448.     for (i = 1; i <= i__2; ++i) {
  14449.     do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
  14450.     }
  14451.     i__3 = data_1.n;
  14452.     for (i = 1; i <= i__3; ++i) {
  14453.     do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
  14454.  
  14455.     }
  14456.     e_wsue();
  14457. /*<       WRITE( IGFL) ( BET( I), I=1, N),( SALP( I), I=1, N) >*/
  14458.     io___1020.ciunit = igfl;
  14459.     s_wsue(&io___1020);
  14460.     i__1 = data_1.n;
  14461.     for (i = 1; i <= i__1; ++i) {
  14462.     do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
  14463.  
  14464.     }
  14465.     i__2 = data_1.n;
  14466.     for (i = 1; i <= i__2; ++i) {
  14467.     do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
  14468.         ;
  14469.     }
  14470.     e_wsue();
  14471. /*<       WRITE( IGFL) ( ICON1( I), I=1, N),( ICON2( I), I=1, N) >*/
  14472.     io___1021.ciunit = igfl;
  14473.     s_wsue(&io___1021);
  14474.     i__1 = data_1.n;
  14475.     for (i = 1; i <= i__1; ++i) {
  14476.     do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
  14477.     }
  14478.     i__2 = data_1.n;
  14479.     for (i = 1; i <= i__2; ++i) {
  14480.     do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
  14481.     }
  14482.     e_wsue();
  14483. /*<       WRITE( IGFL) ( ITAG( I), I=1, N) >*/
  14484.     io___1022.ciunit = igfl;
  14485.     s_wsue(&io___1022);
  14486.     i__1 = data_1.n;
  14487.     for (i = 1; i <= i__1; ++i) {
  14488.     do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
  14489.     }
  14490.     e_wsue();
  14491. /*<       IF( NLOAD.GT.0) WRITE( IGFL) ( ZARRAY( I), I=1, N) >*/
  14492.     if (zload_1.nload > 0) {
  14493.     io___1023.ciunit = igfl;
  14494.     s_wsue(&io___1023);
  14495.     i__1 = data_1.n;
  14496.     for (i = 1; i <= i__1; ++i) {
  14497.         do_uio(&c__2, (char *)&zload_1.zarray[i - 1], (ftnlen)sizeof(
  14498.             doublereal));
  14499.     }
  14500.     e_wsue();
  14501.     }
  14502. /*<     1 IF( M.EQ.0) GOTO 2 >*/
  14503. L1:
  14504.     if (data_1.m == 0) {
  14505.     goto L2;
  14506.     }
  14507. /*<       J= LD- M+1 >*/
  14508.     j = data_1.ld - data_1.m + 1;
  14509. /*<    >*/
  14510.     io___1025.ciunit = igfl;
  14511.     s_wsue(&io___1025);
  14512.     i__1 = data_1.ld;
  14513.     for (i = j; i <= i__1; ++i) {
  14514.     do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
  14515.     }
  14516.     i__2 = data_1.ld;
  14517.     for (i = j; i <= i__2; ++i) {
  14518.     do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
  14519.     }
  14520.     i__3 = data_1.ld;
  14521.     for (i = j; i <= i__3; ++i) {
  14522.     do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
  14523.     }
  14524.     e_wsue();
  14525. /*<    >*/
  14526.     io___1026.ciunit = igfl;
  14527.     s_wsue(&io___1026);
  14528.     i__1 = data_1.ld;
  14529.     for (i = j; i <= i__1; ++i) {
  14530.     do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
  14531.     }
  14532.     i__2 = data_1.ld;
  14533.     for (i = j; i <= i__2; ++i) {
  14534.     do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
  14535.     }
  14536.     i__3 = data_1.ld;
  14537.     for (i = j; i <= i__3; ++i) {
  14538.     do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
  14539.  
  14540.     }
  14541.     e_wsue();
  14542. /*<       WRITE( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD) >*/
  14543.     io___1027.ciunit = igfl;
  14544.     s_wsue(&io___1027);
  14545.     i__1 = data_1.ld;
  14546.     for (i = j; i <= i__1; ++i) {
  14547.     do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
  14548.  
  14549.     }
  14550.     i__2 = data_1.ld;
  14551.     for (i = j; i <= i__2; ++i) {
  14552.     do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
  14553.         ;
  14554.     }
  14555.     e_wsue();
  14556. /*<       WRITE( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD) >*/
  14557.     io___1028.ciunit = igfl;
  14558.     s_wsue(&io___1028);
  14559.     i__1 = data_1.ld;
  14560.     for (i = j; i <= i__1; ++i) {
  14561.     do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
  14562.     }
  14563.     i__2 = data_1.ld;
  14564.     for (i = j; i <= i__2; ++i) {
  14565.     do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
  14566.     }
  14567.     e_wsue();
  14568. /*<       WRITE( IGFL) ( ITAG( I), I= J, LD) >*/
  14569.     io___1029.ciunit = igfl;
  14570.     s_wsue(&io___1029);
  14571.     i__1 = data_1.ld;
  14572.     for (i = j; i <= i__1; ++i) {
  14573.     do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
  14574.     }
  14575.     e_wsue();
  14576. /*<    >*/
  14577. L2:
  14578.     io___1030.ciunit = igfl;
  14579.     s_wsue(&io___1030);
  14580.     do_uio(&c__1, (char *)&matpar_1.icase, (ftnlen)sizeof(integer));
  14581.     do_uio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
  14582.     do_uio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
  14583.     do_uio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
  14584.     do_uio(&c__1, (char *)&matpar_1.nblsym, (ftnlen)sizeof(integer));
  14585.     do_uio(&c__1, (char *)&matpar_1.npsym, (ftnlen)sizeof(integer));
  14586.     do_uio(&c__1, (char *)&matpar_1.nlsym, (ftnlen)sizeof(integer));
  14587.     do_uio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
  14588.     e_wsue();
  14589. /*<    >*/
  14590.     if (gnd_1.iperf == 2) {
  14591.     io___1031.ciunit = igfl;
  14592.     s_wsue(&io___1031);
  14593.     do_uio(&c__880, (char *)&ggrid_1.ar1[0], (ftnlen)sizeof(doublereal));
  14594.     do_uio(&c__680, (char *)&ggrid_1.ar2[0], (ftnlen)sizeof(doublereal));
  14595.     do_uio(&c__576, (char *)&ggrid_1.ar3[0], (ftnlen)sizeof(doublereal));
  14596.     do_uio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
  14597.     do_uio(&c__3, (char *)&ggrid_1.dxa[0], (ftnlen)sizeof(doublereal));
  14598.     do_uio(&c__3, (char *)&ggrid_1.dya[0], (ftnlen)sizeof(doublereal));
  14599.     do_uio(&c__3, (char *)&ggrid_1.xsa[0], (ftnlen)sizeof(doublereal));
  14600.     do_uio(&c__3, (char *)&ggrid_1.ysa[0], (ftnlen)sizeof(doublereal));
  14601.     do_uio(&c__3, (char *)&ggrid_1.nxa[0], (ftnlen)sizeof(integer));
  14602.     do_uio(&c__3, (char *)&ggrid_1.nya[0], (ftnlen)sizeof(integer));
  14603.     e_wsue();
  14604.     }
  14605. /*<       IF( NOP.GT.1) WRITE( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP) >*/
  14606.     if (nop > 1) {
  14607.     io___1032.ciunit = igfl;
  14608.     s_wsue(&io___1032);
  14609.     i__1 = nop;
  14610.     for (j = 1; j <= i__1; ++j) {
  14611.         i__2 = nop;
  14612.         for (i = 1; i <= i__2; ++i) {
  14613.         do_uio(&c__2, (char *)&smat_1.ssx[i + (j << 4) - 17], (ftnlen)
  14614.             sizeof(doublereal));
  14615.         }
  14616.     }
  14617.     e_wsue();
  14618.     }
  14619. /*<       WRITE( IGFL) ( IP( I), I=1, NEQ), COM >*/
  14620.     io___1033.ciunit = igfl;
  14621.     s_wsue(&io___1033);
  14622.     i__2 = neq;
  14623.     for (i = 1; i <= i__2; ++i) {
  14624.     do_uio(&c__1, (char *)&save_1.ip[i - 1], (ftnlen)sizeof(integer));
  14625.     }
  14626.     do_uio(&c__95, (char *)&save_1.com[0], (ftnlen)sizeof(doublereal));
  14627.     e_wsue();
  14628. /*<       IF( ICASE.GT.2) GOTO 3 >*/
  14629.     if (matpar_1.icase > 2) {
  14630.     goto L3;
  14631.     }
  14632. /*<       IOUT= NEQ* NPEQ >*/
  14633.     iout = neq * npeq;
  14634. /*<       WRITE( IGFL) ( CM( I), I=1, IOUT) >*/
  14635.     io___1035.ciunit = igfl;
  14636.     s_wsue(&io___1035);
  14637.     i__2 = iout;
  14638.     for (i = 1; i <= i__2; ++i) {
  14639.     do_uio(&c__2, (char *)&cmb_1.cm[i - 1], (ftnlen)sizeof(doublereal));
  14640.     }
  14641.     e_wsue();
  14642. /*<       GOTO 12 >*/
  14643.     goto L12;
  14644. /*<     3 IF( ICASE.NE.4) GOTO 5 >*/
  14645. L3:
  14646.     if (matpar_1.icase != 4) {
  14647.     goto L5;
  14648.     }
  14649. /*<       REWIND 13 >*/
  14650.     al__1.aerr = 0;
  14651.     al__1.aunit = 13;
  14652.     f_rew(&al__1);
  14653. /*<       I= NPEQ* NPEQ >*/
  14654.     i = npeq * npeq;
  14655. /*<       DO 4  K=1, NOP >*/
  14656.     i__2 = nop;
  14657.     for (k = 1; k <= i__2; ++k) {
  14658. /*<       READ( 13) ( CM( J), J=1, I) >*/
  14659.     s_rsue(&io___1037);
  14660.     i__1 = i;
  14661.     for (j = 1; j <= i__1; ++j) {
  14662.         do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
  14663.             );
  14664.     }
  14665.     e_rsue();
  14666. /*<     4 WRITE( IGFL) ( CM( J), J=1, I) >*/
  14667. /* L4: */
  14668.     io___1038.ciunit = igfl;
  14669.     s_wsue(&io___1038);
  14670.     i__1 = i;
  14671.     for (j = 1; j <= i__1; ++j) {
  14672.         do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
  14673.             );
  14674.     }
  14675.     e_wsue();
  14676.     }
  14677. /*<       REWIND 13 >*/
  14678.     al__1.aerr = 0;
  14679.     al__1.aunit = 13;
  14680.     f_rew(&al__1);
  14681. /*<       GOTO 12 >*/
  14682.     goto L12;
  14683. /*<     5 REWIND 13 >*/
  14684. L5:
  14685.     al__1.aerr = 0;
  14686.     al__1.aunit = 13;
  14687.     f_rew(&al__1);
  14688. /*<       REWIND 14 >*/
  14689.     al__1.aerr = 0;
  14690.     al__1.aunit = 14;
  14691.     f_rew(&al__1);
  14692. /*<       IF( ICASE.EQ.5) GOTO 8 >*/
  14693.     if (matpar_1.icase == 5) {
  14694.     goto L8;
  14695.     }
  14696. /*<       IOUT= NPBLK* NEQ*2 >*/
  14697.     iout = matpar_1.npblk * neq << 1;
  14698. /*<       DO 6  I=1, NBLOKS >*/
  14699.     i__1 = matpar_1.nbloks;
  14700.     for (i = 1; i <= i__1; ++i) {
  14701. /*<       CALL BLCKIN( CM,13,1, IOUT,1,201) >*/
  14702.     blckin_(cmb_1.cm, &c__13, &c__1, &iout, &c__1, &c__201);
  14703. /*<     6 CALL BLCKOT( CM, IGFL,1, IOUT,1,202) >*/
  14704. /* L6: */
  14705.     blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__202);
  14706.     }
  14707. /*<       DO 7  I=1, NBLOKS >*/
  14708.     i__1 = matpar_1.nbloks;
  14709.     for (i = 1; i <= i__1; ++i) {
  14710. /*<       CALL BLCKIN( CM,14,1, IOUT,1,203) >*/
  14711.     blckin_(cmb_1.cm, &c__14, &c__1, &iout, &c__1, &c__203);
  14712. /*<     7 CALL BLCKOT( CM, IGFL,1, IOUT,1,204) >*/
  14713. /* L7: */
  14714.     blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__204);
  14715.     }
  14716. /*<       GOTO 12 >*/
  14717.     goto L12;
  14718. /*<     8 IOUT= NPSYM* NPEQ*2 >*/
  14719. L8:
  14720.     iout = matpar_1.npsym * npeq << 1;
  14721. /*<       DO 11  IOP=1, NOP >*/
  14722.     i__1 = nop;
  14723.     for (iop = 1; iop <= i__1; ++iop) {
  14724. /*<       DO 9  I=1, NBLSYM >*/
  14725.     i__2 = matpar_1.nblsym;
  14726.     for (i = 1; i <= i__2; ++i) {
  14727. /*<       CALL BLCKIN( CM,13,1, IOUT,1,205) >*/
  14728.         blckin_(cmb_1.cm, &c__13, &c__1, &iout, &c__1, &c__205);
  14729. /*<     9 CALL BLCKOT( CM, IGFL,1, IOUT,1,206) >*/
  14730. /* L9: */
  14731.         blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__206);
  14732.     }
  14733. /*<       DO 10  I=1, NBLSYM >*/
  14734.     i__2 = matpar_1.nblsym;
  14735.     for (i = 1; i <= i__2; ++i) {
  14736. /*<       CALL BLCKIN( CM,14,1, IOUT,1,207) >*/
  14737.         blckin_(cmb_1.cm, &c__14, &c__1, &iout, &c__1, &c__207);
  14738. /*<    10 CALL BLCKOT( CM, IGFL,1, IOUT,1,208) >*/
  14739. /* L10: */
  14740.         blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__208);
  14741.     }
  14742. /*<    11 CONTINUE >*/
  14743. /* L11: */
  14744.     }
  14745. /*<       REWIND 13 >*/
  14746.     al__1.aerr = 0;
  14747.     al__1.aunit = 13;
  14748.     f_rew(&al__1);
  14749. /*<       REWIND 14 >*/
  14750.     al__1.aerr = 0;
  14751.     al__1.aunit = 14;
  14752.     f_rew(&al__1);
  14753. /*<    12 REWIND IGFL >*/
  14754. L12:
  14755.     al__1.aerr = 0;
  14756.     al__1.aunit = igfl;
  14757.     f_rew(&al__1);
  14758. /*<       WRITE( 6,13)  IGFL, IMAT >*/
  14759.     s_wsfe(&io___1040);
  14760.     do_fio(&c__1, (char *)&igfl, (ftnlen)sizeof(integer));
  14761.     do_fio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
  14762.     e_wsfe();
  14763.  
  14764. /*<       RETURN >*/
  14765.     return 0;
  14766. /*<    >*/
  14767. /*<       END >*/
  14768. } /* gfout_ */
  14769.  
  14770. /* *** */
  14771. /*     DOUBLE PRECISION 6/4/85 */
  14772.  
  14773. /*<       SUBROUTINE GH( ZK, HR, HI) >*/
  14774. /* Subroutine */ int gh_(zk, hr, hi)
  14775. doublereal *zk, *hr, *hi;
  14776. {
  14777.     /* Builtin functions */
  14778.     double sqrt(), cos(), sin();
  14779.  
  14780.     /* Local variables */
  14781.     static doublereal r, rs, rr2, rr3, ckr, skr;
  14782.  
  14783. /* *** */
  14784. /*     INTEGRAND FOR H FIELD OF A WIRE */
  14785. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  14786. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  14787. /*<       COMMON  /TMH/ ZPK, RHKS >*/
  14788. /*<       RS= ZK- ZPK >*/
  14789.     rs = *zk - tmh_1.zpk;
  14790. /*<       RS= RHKS+ RS* RS >*/
  14791.     rs = tmh_1.rhks + rs * rs;
  14792. /*<       R= SQRT( RS) >*/
  14793.     r = sqrt(rs);
  14794. /*<       CKR= COS( R) >*/
  14795.     ckr = cos(r);
  14796. /*<       SKR= SIN( R) >*/
  14797.     skr = sin(r);
  14798. /*<       RR2=1./ RS >*/
  14799.     rr2 = 1. / rs;
  14800. /*<       RR3= RR2/ R >*/
  14801.     rr3 = rr2 / r;
  14802. /*<       HR= SKR* RR2+ CKR* RR3 >*/
  14803.     *hr = skr * rr2 + ckr * rr3;
  14804. /*<       HI= CKR* RR2- SKR* RR3 >*/
  14805.     *hi = ckr * rr2 - skr * rr3;
  14806. /*<       RETURN >*/
  14807.     return 0;
  14808. /*<       END >*/
  14809. } /* gh_ */
  14810.  
  14811. /* *** */
  14812. /*     DOUBLE PRECISION 6/4/85 */
  14813.  
  14814. /*<       SUBROUTINE GWAVE( ERV, EZV, ERH, EZH, EPH) >*/
  14815. /* Subroutine */ int gwave_(erv, ezv, erh, ezh, eph)
  14816. doublecomplex *erv, *ezv, *erh, *ezh, *eph;
  14817. {
  14818.     /* Initialized data */
  14819.  
  14820.     static struct {
  14821.     doublereal e_1[3];
  14822.     } equiv_0 = { 0., 1., 0. };
  14823.  
  14824.     static struct {
  14825.     doublereal e_1[3];
  14826.     } equiv_1 = { 0., 6.283185308, 0. };
  14827.  
  14828.     static struct {
  14829.     doublereal e_1[3];
  14830.     } equiv_2 = { 0., -188.367, 0. };
  14831.  
  14832.  
  14833.     /* System generated locals */
  14834.     doublereal d__1, d__2;
  14835.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
  14836.          z__11, z__12, z__13, z__14;
  14837.  
  14838.     /* Builtin functions */
  14839.     double sqrt();
  14840.     void z_sqrt(), z_div();
  14841.  
  14842.     /* Local variables */
  14843.     extern /* Double Complex */ int fbar_();
  14844. #define econ ((doublecomplex *)&equiv_2)
  14845.     static doublereal cppp, sppp;
  14846. #define tpjx ((doublereal *)&equiv_1)
  14847.     static doublereal cppp2, sppp2;
  14848.     static doublecomplex f, g, v, w;
  14849. #define econx ((doublereal *)&equiv_2)
  14850.     static doublecomplex p1, q1, t1, t2, t3, t4, x1, x2, x3, x4, x5, x6, x7;
  14851. #define fj ((doublecomplex *)&equiv_0)
  14852.     static doublecomplex rh, rv, rk1, rk2, xr1, xr2;
  14853.     static doublereal cpp;
  14854. #define fjx ((doublereal *)&equiv_0)
  14855. #define tpj ((doublecomplex *)&equiv_1)
  14856.     static doublecomplex omr;
  14857.     static doublereal spp, cpp2, spp2;
  14858.  
  14859. /* *** */
  14860.  
  14861. /*     GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A */
  14862. /*     CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON 
  14863. */
  14864. /*     (PROC. IRE, SEPT., 1937, PP.1203,1236.) */
  14865.  
  14866. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  14867. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  14868. /*<    >*/
  14869. /*<       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
  14870. /*<       DIMENSION  FJX(2), TPJX(2), ECONX(2) >*/
  14871. /*<       EQUIVALENCE(FJ,FJX),(TPJ,TPJX),(ECON,ECONX) >*/
  14872. /*<       DATA   PI/3.141592654D+0/, FJX/0.,1./, TPJX/0.,6.283185308D+0/ >*/
  14873. /*<       DATA   ECONX/0.,-188.367/ >*/
  14874. /*<       SPPP= ZMH/ R1 >*/
  14875.     sppp = gwav_1.zmh / gwav_1.r1;
  14876. /*<       SPPP2= SPPP* SPPP >*/
  14877.     sppp2 = sppp * sppp;
  14878. /*<       CPPP2=1.- SPPP2 >*/
  14879.     cppp2 = 1. - sppp2;
  14880. /*<       IF( CPPP2.LT.1.D-20) CPPP2=1.D-20 >*/
  14881.     if (cppp2 < 1e-20) {
  14882.     cppp2 = 1e-20;
  14883.     }
  14884. /*<       CPPP= SQRT( CPPP2) >*/
  14885.     cppp = sqrt(cppp2);
  14886. /*<       SPP= ZPH/ R2 >*/
  14887.     spp = gwav_1.zph / gwav_1.r2;
  14888. /*<       SPP2= SPP* SPP >*/
  14889.     spp2 = spp * spp;
  14890. /*<       CPP2=1.- SPP2 >*/
  14891.     cpp2 = 1. - spp2;
  14892. /*<       IF( CPP2.LT.1.D-20) CPP2=1.D-20 >*/
  14893.     if (cpp2 < 1e-20) {
  14894.     cpp2 = 1e-20;
  14895.     }
  14896. /*<       CPP= SQRT( CPP2) >*/
  14897.     cpp = sqrt(cpp2);
  14898. /*<       RK1=- TPJ* R1 >*/
  14899.     z__2.r = -tpj->r, z__2.i = -tpj->i;
  14900.     z__1.r = gwav_1.r1 * z__2.r, z__1.i = gwav_1.r1 * z__2.i;
  14901.     rk1.r = z__1.r, rk1.i = z__1.i;
  14902. /*<       RK2=- TPJ* R2 >*/
  14903.     z__2.r = -tpj->r, z__2.i = -tpj->i;
  14904.     z__1.r = gwav_1.r2 * z__2.r, z__1.i = gwav_1.r2 * z__2.i;
  14905.     rk2.r = z__1.r, rk2.i = z__1.i;
  14906. /*<       T1=1.- U2* CPP2 >*/
  14907.     z__2.r = cpp2 * gwav_1.u2.r, z__2.i = cpp2 * gwav_1.u2.i;
  14908.     z__1.r = 1. - z__2.r, z__1.i = -z__2.i;
  14909.     t1.r = z__1.r, t1.i = z__1.i;
  14910. /*<       T2= SQRT( T1) >*/
  14911.     z_sqrt(&z__1, &t1);
  14912.     t2.r = z__1.r, t2.i = z__1.i;
  14913. /*<       T3=(1.-1./ RK1)/ RK1 >*/
  14914.     z_div(&z__3, &c_b48, &rk1);
  14915.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  14916.     z_div(&z__1, &z__2, &rk1);
  14917.     t3.r = z__1.r, t3.i = z__1.i;
  14918. /*<       T4=(1.-1./ RK2)/ RK2 >*/
  14919.     z_div(&z__3, &c_b48, &rk2);
  14920.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  14921.     z_div(&z__1, &z__2, &rk2);
  14922.     t4.r = z__1.r, t4.i = z__1.i;
  14923. /*<       P1= RK2* U2* T1/(2.* CPP2) >*/
  14924.     z__3.r = rk2.r * gwav_1.u2.r - rk2.i * gwav_1.u2.i, z__3.i = rk2.r * 
  14925.         gwav_1.u2.i + rk2.i * gwav_1.u2.r;
  14926.     z__2.r = z__3.r * t1.r - z__3.i * t1.i, z__2.i = z__3.r * t1.i + z__3.i * 
  14927.         t1.r;
  14928.     d__1 = cpp2 * 2.;
  14929.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  14930.     p1.r = z__1.r, p1.i = z__1.i;
  14931. /*<       RV=( SPP- U* T2)/( SPP+ U* T2) >*/
  14932.     z__3.r = gwav_1.u.r * t2.r - gwav_1.u.i * t2.i, z__3.i = gwav_1.u.r * 
  14933.         t2.i + gwav_1.u.i * t2.r;
  14934.     z__2.r = spp - z__3.r, z__2.i = -z__3.i;
  14935.     z__5.r = gwav_1.u.r * t2.r - gwav_1.u.i * t2.i, z__5.i = gwav_1.u.r * 
  14936.         t2.i + gwav_1.u.i * t2.r;
  14937.     z__4.r = spp + z__5.r, z__4.i = z__5.i;
  14938.     z_div(&z__1, &z__2, &z__4);
  14939.     rv.r = z__1.r, rv.i = z__1.i;
  14940. /*<       OMR=1.- RV >*/
  14941.     z__1.r = 1. - rv.r, z__1.i = -rv.i;
  14942.     omr.r = z__1.r, omr.i = z__1.i;
  14943. /*<       W=1./ OMR >*/
  14944.     z_div(&z__1, &c_b48, &omr);
  14945.     w.r = z__1.r, w.i = z__1.i;
  14946. /*<       W=(4.,0.)* P1* W* W >*/
  14947.     z__3.r = p1.r * 4. - p1.i * 0., z__3.i = p1.r * 0. + p1.i * 4.;
  14948.     z__2.r = z__3.r * w.r - z__3.i * w.i, z__2.i = z__3.r * w.i + z__3.i * 
  14949.         w.r;
  14950.     z__1.r = z__2.r * w.r - z__2.i * w.i, z__1.i = z__2.r * w.i + z__2.i * 
  14951.         w.r;
  14952.     w.r = z__1.r, w.i = z__1.i;
  14953. /*<       F= FBAR( W) >*/
  14954.     fbar_(&z__1, &w);
  14955.     f.r = z__1.r, f.i = z__1.i;
  14956. /*<       Q1= RK2* T1/(2.* U2* CPP2) >*/
  14957.     z__2.r = rk2.r * t1.r - rk2.i * t1.i, z__2.i = rk2.r * t1.i + rk2.i * 
  14958.         t1.r;
  14959.     z__4.r = gwav_1.u2.r * 2., z__4.i = gwav_1.u2.i * 2.;
  14960.     z__3.r = cpp2 * z__4.r, z__3.i = cpp2 * z__4.i;
  14961.     z_div(&z__1, &z__2, &z__3);
  14962.     q1.r = z__1.r, q1.i = z__1.i;
  14963. /*<       RH=( T2- U* SPP)/( T2+ U* SPP) >*/
  14964.     z__3.r = spp * gwav_1.u.r, z__3.i = spp * gwav_1.u.i;
  14965.     z__2.r = t2.r - z__3.r, z__2.i = t2.i - z__3.i;
  14966.     z__5.r = spp * gwav_1.u.r, z__5.i = spp * gwav_1.u.i;
  14967.     z__4.r = t2.r + z__5.r, z__4.i = t2.i + z__5.i;
  14968.     z_div(&z__1, &z__2, &z__4);
  14969.     rh.r = z__1.r, rh.i = z__1.i;
  14970. /*<       V=1./(1.+ RH) >*/
  14971.     z__2.r = rh.r + 1., z__2.i = rh.i;
  14972.     z_div(&z__1, &c_b48, &z__2);
  14973.     v.r = z__1.r, v.i = z__1.i;
  14974. /*<       V=(4.,0.)* Q1* V* V >*/
  14975.     z__3.r = q1.r * 4. - q1.i * 0., z__3.i = q1.r * 0. + q1.i * 4.;
  14976.     z__2.r = z__3.r * v.r - z__3.i * v.i, z__2.i = z__3.r * v.i + z__3.i * 
  14977.         v.r;
  14978.     z__1.r = z__2.r * v.r - z__2.i * v.i, z__1.i = z__2.r * v.i + z__2.i * 
  14979.         v.r;
  14980.     v.r = z__1.r, v.i = z__1.i;
  14981. /*<       G= FBAR( V) >*/
  14982.     fbar_(&z__1, &v);
  14983.     g.r = z__1.r, g.i = z__1.i;
  14984. /*<       XR1= XX1/ R1 >*/
  14985.     z__1.r = gwav_1.xx1.r / gwav_1.r1, z__1.i = gwav_1.xx1.i / gwav_1.r1;
  14986.     xr1.r = z__1.r, xr1.i = z__1.i;
  14987. /*<       XR2= XX2/ R2 >*/
  14988.     z__1.r = gwav_1.xx2.r / gwav_1.r2, z__1.i = gwav_1.xx2.i / gwav_1.r2;
  14989.     xr2.r = z__1.r, xr2.i = z__1.i;
  14990. /*<       X1= CPPP2* XR1 >*/
  14991.     z__1.r = cppp2 * xr1.r, z__1.i = cppp2 * xr1.i;
  14992.     x1.r = z__1.r, x1.i = z__1.i;
  14993. /*<       X2= RV* CPP2* XR2 >*/
  14994.     z__2.r = cpp2 * rv.r, z__2.i = cpp2 * rv.i;
  14995.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  14996.         z__2.i * xr2.r;
  14997.     x2.r = z__1.r, x2.i = z__1.i;
  14998. /*<       X3= OMR* CPP2* F* XR2 >*/
  14999.     z__3.r = cpp2 * omr.r, z__3.i = cpp2 * omr.i;
  15000.     z__2.r = z__3.r * f.r - z__3.i * f.i, z__2.i = z__3.r * f.i + z__3.i * 
  15001.         f.r;
  15002.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15003.         z__2.i * xr2.r;
  15004.     x3.r = z__1.r, x3.i = z__1.i;
  15005. /*<       X4= U* T2* SPP*2.* XR2/ RK2 >*/
  15006.     z__5.r = gwav_1.u.r * t2.r - gwav_1.u.i * t2.i, z__5.i = gwav_1.u.r * 
  15007.         t2.i + gwav_1.u.i * t2.r;
  15008.     z__4.r = spp * z__5.r, z__4.i = spp * z__5.i;
  15009.     z__3.r = z__4.r * 2., z__3.i = z__4.i * 2.;
  15010.     z__2.r = z__3.r * xr2.r - z__3.i * xr2.i, z__2.i = z__3.r * xr2.i + 
  15011.         z__3.i * xr2.r;
  15012.     z_div(&z__1, &z__2, &rk2);
  15013.     x4.r = z__1.r, x4.i = z__1.i;
  15014. /*<       X5= XR1* T3*(1.-3.* SPPP2) >*/
  15015.     z__2.r = xr1.r * t3.r - xr1.i * t3.i, z__2.i = xr1.r * t3.i + xr1.i * 
  15016.         t3.r;
  15017.     d__1 = 1. - sppp2 * 3.;
  15018.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  15019.     x5.r = z__1.r, x5.i = z__1.i;
  15020. /*<       X6= XR2* T4*(1.-3.* SPP2) >*/
  15021.     z__2.r = xr2.r * t4.r - xr2.i * t4.i, z__2.i = xr2.r * t4.i + xr2.i * 
  15022.         t4.r;
  15023.     d__1 = 1. - spp2 * 3.;
  15024.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  15025.     x6.r = z__1.r, x6.i = z__1.i;
  15026. /*<       EZV=( X1+ X2+ X3- X4- X5- X6)* ECON >*/
  15027.     z__6.r = x1.r + x2.r, z__6.i = x1.i + x2.i;
  15028.     z__5.r = z__6.r + x3.r, z__5.i = z__6.i + x3.i;
  15029.     z__4.r = z__5.r - x4.r, z__4.i = z__5.i - x4.i;
  15030.     z__3.r = z__4.r - x5.r, z__3.i = z__4.i - x5.i;
  15031.     z__2.r = z__3.r - x6.r, z__2.i = z__3.i - x6.i;
  15032.     z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i + 
  15033.         z__2.i * econ->r;
  15034.     ezv->r = z__1.r, ezv->i = z__1.i;
  15035. /*<       X1= SPPP* CPPP* XR1 >*/
  15036.     d__1 = sppp * cppp;
  15037.     z__1.r = d__1 * xr1.r, z__1.i = d__1 * xr1.i;
  15038.     x1.r = z__1.r, x1.i = z__1.i;
  15039. /*<       X2= RV* SPP* CPP* XR2 >*/
  15040.     z__3.r = spp * rv.r, z__3.i = spp * rv.i;
  15041.     z__2.r = cpp * z__3.r, z__2.i = cpp * z__3.i;
  15042.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15043.         z__2.i * xr2.r;
  15044.     x2.r = z__1.r, x2.i = z__1.i;
  15045. /*<       X3= CPP* OMR* U* T2* F* XR2 >*/
  15046.     z__5.r = cpp * omr.r, z__5.i = cpp * omr.i;
  15047.     z__4.r = z__5.r * gwav_1.u.r - z__5.i * gwav_1.u.i, z__4.i = z__5.r * 
  15048.         gwav_1.u.i + z__5.i * gwav_1.u.r;
  15049.     z__3.r = z__4.r * t2.r - z__4.i * t2.i, z__3.i = z__4.r * t2.i + z__4.i * 
  15050.         t2.r;
  15051.     z__2.r = z__3.r * f.r - z__3.i * f.i, z__2.i = z__3.r * f.i + z__3.i * 
  15052.         f.r;
  15053.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15054.         z__2.i * xr2.r;
  15055.     x3.r = z__1.r, x3.i = z__1.i;
  15056. /*<       X4= SPP* CPP* OMR* XR2/ RK2 >*/
  15057.     d__1 = spp * cpp;
  15058.     z__3.r = d__1 * omr.r, z__3.i = d__1 * omr.i;
  15059.     z__2.r = z__3.r * xr2.r - z__3.i * xr2.i, z__2.i = z__3.r * xr2.i + 
  15060.         z__3.i * xr2.r;
  15061.     z_div(&z__1, &z__2, &rk2);
  15062.     x4.r = z__1.r, x4.i = z__1.i;
  15063. /*<       X5=3.* SPPP* CPPP* T3* XR1 >*/
  15064.     d__2 = sppp * 3.;
  15065.     d__1 = d__2 * cppp;
  15066.     z__2.r = d__1 * t3.r, z__2.i = d__1 * t3.i;
  15067.     z__1.r = z__2.r * xr1.r - z__2.i * xr1.i, z__1.i = z__2.r * xr1.i + 
  15068.         z__2.i * xr1.r;
  15069.     x5.r = z__1.r, x5.i = z__1.i;
  15070. /*<       X6= CPP* U* T2* OMR* XR2/ RK2*.5 >*/
  15071.     z__6.r = cpp * gwav_1.u.r, z__6.i = cpp * gwav_1.u.i;
  15072.     z__5.r = z__6.r * t2.r - z__6.i * t2.i, z__5.i = z__6.r * t2.i + z__6.i * 
  15073.         t2.r;
  15074.     z__4.r = z__5.r * omr.r - z__5.i * omr.i, z__4.i = z__5.r * omr.i + 
  15075.         z__5.i * omr.r;
  15076.     z__3.r = z__4.r * xr2.r - z__4.i * xr2.i, z__3.i = z__4.r * xr2.i + 
  15077.         z__4.i * xr2.r;
  15078.     z_div(&z__2, &z__3, &rk2);
  15079.     z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
  15080.     x6.r = z__1.r, x6.i = z__1.i;
  15081. /*<       X7=3.* SPP* CPP* T4* XR2 >*/
  15082.     d__2 = spp * 3.;
  15083.     d__1 = d__2 * cpp;
  15084.     z__2.r = d__1 * t4.r, z__2.i = d__1 * t4.i;
  15085.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15086.         z__2.i * xr2.r;
  15087.     x7.r = z__1.r, x7.i = z__1.i;
  15088. /*<       ERV=-( X1+ X2- X3+ X4- X5+ X6- X7)* ECON >*/
  15089.     z__8.r = x1.r + x2.r, z__8.i = x1.i + x2.i;
  15090.     z__7.r = z__8.r - x3.r, z__7.i = z__8.i - x3.i;
  15091.     z__6.r = z__7.r + x4.r, z__6.i = z__7.i + x4.i;
  15092.     z__5.r = z__6.r - x5.r, z__5.i = z__6.i - x5.i;
  15093.     z__4.r = z__5.r + x6.r, z__4.i = z__5.i + x6.i;
  15094.     z__3.r = z__4.r - x7.r, z__3.i = z__4.i - x7.i;
  15095.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  15096.     z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i + 
  15097.         z__2.i * econ->r;
  15098.     erv->r = z__1.r, erv->i = z__1.i;
  15099. /*<       EZH=-( X1- X2+ X3- X4- X5- X6+ X7)* ECON >*/
  15100.     z__8.r = x1.r - x2.r, z__8.i = x1.i - x2.i;
  15101.     z__7.r = z__8.r + x3.r, z__7.i = z__8.i + x3.i;
  15102.     z__6.r = z__7.r - x4.r, z__6.i = z__7.i - x4.i;
  15103.     z__5.r = z__6.r - x5.r, z__5.i = z__6.i - x5.i;
  15104.     z__4.r = z__5.r - x6.r, z__4.i = z__5.i - x6.i;
  15105.     z__3.r = z__4.r + x7.r, z__3.i = z__4.i + x7.i;
  15106.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  15107.     z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i + 
  15108.         z__2.i * econ->r;
  15109.     ezh->r = z__1.r, ezh->i = z__1.i;
  15110. /*<       X1= SPPP2* XR1 >*/
  15111.     z__1.r = sppp2 * xr1.r, z__1.i = sppp2 * xr1.i;
  15112.     x1.r = z__1.r, x1.i = z__1.i;
  15113. /*<       X2= RV* SPP2* XR2 >*/
  15114.     z__2.r = spp2 * rv.r, z__2.i = spp2 * rv.i;
  15115.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15116.         z__2.i * xr2.r;
  15117.     x2.r = z__1.r, x2.i = z__1.i;
  15118. /*<       X4= U2* T1* OMR* F* XR2 >*/
  15119.     z__4.r = gwav_1.u2.r * t1.r - gwav_1.u2.i * t1.i, z__4.i = gwav_1.u2.r * 
  15120.         t1.i + gwav_1.u2.i * t1.r;
  15121.     z__3.r = z__4.r * omr.r - z__4.i * omr.i, z__3.i = z__4.r * omr.i + 
  15122.         z__4.i * omr.r;
  15123.     z__2.r = z__3.r * f.r - z__3.i * f.i, z__2.i = z__3.r * f.i + z__3.i * 
  15124.         f.r;
  15125.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15126.         z__2.i * xr2.r;
  15127.     x4.r = z__1.r, x4.i = z__1.i;
  15128. /*<       X5= T3*(1.-3.* CPPP2)* XR1 >*/
  15129.     d__1 = 1. - cppp2 * 3.;
  15130.     z__2.r = d__1 * t3.r, z__2.i = d__1 * t3.i;
  15131.     z__1.r = z__2.r * xr1.r - z__2.i * xr1.i, z__1.i = z__2.r * xr1.i + 
  15132.         z__2.i * xr1.r;
  15133.     x5.r = z__1.r, x5.i = z__1.i;
  15134. /*<       X6= T4*(1.-3.* CPP2)*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2 >*/
  15135.     d__1 = 1. - cpp2 * 3.;
  15136.     z__3.r = d__1 * t4.r, z__3.i = d__1 * t4.i;
  15137.     z__7.r = rv.r + 1., z__7.i = rv.i;
  15138.     z__6.r = gwav_1.u2.r * z__7.r - gwav_1.u2.i * z__7.i, z__6.i = 
  15139.         gwav_1.u2.r * z__7.i + gwav_1.u2.i * z__7.r;
  15140.     z__5.r = 1. - z__6.r, z__5.i = -z__6.i;
  15141.     z__9.r = gwav_1.u2.r * omr.r - gwav_1.u2.i * omr.i, z__9.i = gwav_1.u2.r *
  15142.          omr.i + gwav_1.u2.i * omr.r;
  15143.     z__8.r = z__9.r * f.r - z__9.i * f.i, z__8.i = z__9.r * f.i + z__9.i * 
  15144.         f.r;
  15145.     z__4.r = z__5.r - z__8.r, z__4.i = z__5.i - z__8.i;
  15146.     z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i + 
  15147.         z__3.i * z__4.r;
  15148.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15149.         z__2.i * xr2.r;
  15150.     x6.r = z__1.r, x6.i = z__1.i;
  15151. /*<    >*/
  15152.     z__5.r = cpp2 * gwav_1.u2.r, z__5.i = cpp2 * gwav_1.u2.i;
  15153.     z__4.r = z__5.r * omr.r - z__5.i * omr.i, z__4.i = z__5.r * omr.i + 
  15154.         z__5.i * omr.r;
  15155.     z_div(&z__7, &c_b48, &rk2);
  15156.     z__6.r = 1. - z__7.r, z__6.i = -z__7.i;
  15157.     z__3.r = z__4.r * z__6.r - z__4.i * z__6.i, z__3.i = z__4.r * z__6.i + 
  15158.         z__4.i * z__6.r;
  15159.     z__12.r = gwav_1.u2.r * t1.r - gwav_1.u2.i * t1.i, z__12.i = gwav_1.u2.r *
  15160.          t1.i + gwav_1.u2.i * t1.r;
  15161.     z__11.r = z__12.r - spp2, z__11.i = z__12.i;
  15162.     z_div(&z__13, &c_b48, &rk2);
  15163.     z__10.r = z__11.r - z__13.r, z__10.i = z__11.i - z__13.i;
  15164.     z__9.r = f.r * z__10.r - f.i * z__10.i, z__9.i = f.r * z__10.i + f.i * 
  15165.         z__10.r;
  15166.     z_div(&z__14, &c_b48, &rk2);
  15167.     z__8.r = z__9.r + z__14.r, z__8.i = z__9.i + z__14.i;
  15168.     z__2.r = z__3.r * z__8.r - z__3.i * z__8.i, z__2.i = z__3.r * z__8.i + 
  15169.         z__3.i * z__8.r;
  15170.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15171.         z__2.i * xr2.r;
  15172.     x7.r = z__1.r, x7.i = z__1.i;
  15173. /*<       ERH=( X1- X2- X4- X5+ X6+ X7)* ECON >*/
  15174.     z__6.r = x1.r - x2.r, z__6.i = x1.i - x2.i;
  15175.     z__5.r = z__6.r - x4.r, z__5.i = z__6.i - x4.i;
  15176.     z__4.r = z__5.r - x5.r, z__4.i = z__5.i - x5.i;
  15177.     z__3.r = z__4.r + x6.r, z__3.i = z__4.i + x6.i;
  15178.     z__2.r = z__3.r + x7.r, z__2.i = z__3.i + x7.i;
  15179.     z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i + 
  15180.         z__2.i * econ->r;
  15181.     erh->r = z__1.r, erh->i = z__1.i;
  15182. /*<       X1= XR1 >*/
  15183.     x1.r = xr1.r, x1.i = xr1.i;
  15184. /*<       X2= RH* XR2 >*/
  15185.     z__1.r = rh.r * xr2.r - rh.i * xr2.i, z__1.i = rh.r * xr2.i + rh.i * 
  15186.         xr2.r;
  15187.     x2.r = z__1.r, x2.i = z__1.i;
  15188. /*<       X3=( RH+1.)* G* XR2 >*/
  15189.     z__3.r = rh.r + 1., z__3.i = rh.i;
  15190.     z__2.r = z__3.r * g.r - z__3.i * g.i, z__2.i = z__3.r * g.i + z__3.i * 
  15191.         g.r;
  15192.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15193.         z__2.i * xr2.r;
  15194.     x3.r = z__1.r, x3.i = z__1.i;
  15195. /*<       X4= T3* XR1 >*/
  15196.     z__1.r = t3.r * xr1.r - t3.i * xr1.i, z__1.i = t3.r * xr1.i + t3.i * 
  15197.         xr1.r;
  15198.     x4.r = z__1.r, x4.i = z__1.i;
  15199. /*<       X5= T4*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2 >*/
  15200.     z__6.r = rv.r + 1., z__6.i = rv.i;
  15201.     z__5.r = gwav_1.u2.r * z__6.r - gwav_1.u2.i * z__6.i, z__5.i = 
  15202.         gwav_1.u2.r * z__6.i + gwav_1.u2.i * z__6.r;
  15203.     z__4.r = 1. - z__5.r, z__4.i = -z__5.i;
  15204.     z__8.r = gwav_1.u2.r * omr.r - gwav_1.u2.i * omr.i, z__8.i = gwav_1.u2.r *
  15205.          omr.i + gwav_1.u2.i * omr.r;
  15206.     z__7.r = z__8.r * f.r - z__8.i * f.i, z__7.i = z__8.r * f.i + z__8.i * 
  15207.         f.r;
  15208.     z__3.r = z__4.r - z__7.r, z__3.i = z__4.i - z__7.i;
  15209.     z__2.r = t4.r * z__3.r - t4.i * z__3.i, z__2.i = t4.r * z__3.i + t4.i * 
  15210.         z__3.r;
  15211.     z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i + 
  15212.         z__2.i * xr2.r;
  15213.     x5.r = z__1.r, x5.i = z__1.i;
  15214. /*<       X6=.5* U2* OMR*( F*( U2* T1- SPP2-1./ RK2)+1./ RK2)* XR2/ RK2 >*/
  15215.     z__5.r = gwav_1.u2.r * .5, z__5.i = gwav_1.u2.i * .5;
  15216.     z__4.r = z__5.r * omr.r - z__5.i * omr.i, z__4.i = z__5.r * omr.i + 
  15217.         z__5.i * omr.r;
  15218.     z__10.r = gwav_1.u2.r * t1.r - gwav_1.u2.i * t1.i, z__10.i = gwav_1.u2.r *
  15219.          t1.i + gwav_1.u2.i * t1.r;
  15220.     z__9.r = z__10.r - spp2, z__9.i = z__10.i;
  15221.     z_div(&z__11, &c_b48, &rk2);
  15222.     z__8.r = z__9.r - z__11.r, z__8.i = z__9.i - z__11.i;
  15223.     z__7.r = f.r * z__8.r - f.i * z__8.i, z__7.i = f.r * z__8.i + f.i * 
  15224.         z__8.r;
  15225.     z_div(&z__12, &c_b48, &rk2);
  15226.     z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i;
  15227.     z__3.r = z__4.r * z__6.r - z__4.i * z__6.i, z__3.i = z__4.r * z__6.i + 
  15228.         z__4.i * z__6.r;
  15229.     z__2.r = z__3.r * xr2.r - z__3.i * xr2.i, z__2.i = z__3.r * xr2.i + 
  15230.         z__3.i * xr2.r;
  15231.     z_div(&z__1, &z__2, &rk2);
  15232.     x6.r = z__1.r, x6.i = z__1.i;
  15233. /*<       EPH=-( X1- X2+ X3- X4+ X5+ X6)* ECON >*/
  15234.     z__7.r = x1.r - x2.r, z__7.i = x1.i - x2.i;
  15235.     z__6.r = z__7.r + x3.r, z__6.i = z__7.i + x3.i;
  15236.     z__5.r = z__6.r - x4.r, z__5.i = z__6.i - x4.i;
  15237.     z__4.r = z__5.r + x5.r, z__4.i = z__5.i + x5.i;
  15238.     z__3.r = z__4.r + x6.r, z__3.i = z__4.i + x6.i;
  15239.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  15240.     z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i + 
  15241.         z__2.i * econ->r;
  15242.     eph->r = z__1.r, eph->i = z__1.i;
  15243. /*<       RETURN >*/
  15244.     return 0;
  15245. /*<       END >*/
  15246. } /* gwave_ */
  15247.  
  15248. #undef tpj
  15249. #undef fjx
  15250. #undef fj
  15251. #undef econx
  15252. #undef tpjx
  15253. #undef econ
  15254.  
  15255.  
  15256. /* *** */
  15257. /*     DOUBLE PRECISION 6/4/85 */
  15258.  
  15259. /*<       SUBROUTINE GX( ZZ, RH, XK, GZ, GZP) >*/
  15260. /* Subroutine */ int gx_(zz, rh, xk, gz, gzp)
  15261. doublereal *zz, *rh, *xk;
  15262. doublecomplex *gz, *gzp;
  15263. {
  15264.     /* System generated locals */
  15265.     doublereal d__1, d__2;
  15266.     doublecomplex z__1, z__2, z__3, z__4;
  15267.  
  15268.     /* Builtin functions */
  15269.     double sqrt(), cos(), sin();
  15270.  
  15271.     /* Local variables */
  15272.     static doublereal r, r2, rkz;
  15273.  
  15274. /* *** */
  15275. /*     SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX. */
  15276. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  15277. /*<       COMPLEX  GZ, GZP >*/
  15278. /*<       R2= ZZ* ZZ+ RH* RH >*/
  15279.     r2 = *zz * *zz + *rh * *rh;
  15280. /*<       R= SQRT( R2) >*/
  15281.     r = sqrt(r2);
  15282. /*<       RKZ= XK* R >*/
  15283.     rkz = *xk * r;
  15284. /*<       GZ= CMPLX( COS( RKZ),- SIN( RKZ))/ R >*/
  15285.     d__1 = cos(rkz);
  15286.     d__2 = -sin(rkz);
  15287.     z__2.r = d__1, z__2.i = d__2;
  15288.     z__1.r = z__2.r / r, z__1.i = z__2.i / r;
  15289.     gz->r = z__1.r, gz->i = z__1.i;
  15290. /*<       GZP=- CMPLX(1.0, RKZ)* GZ/ R2 >*/
  15291.     z__4.r = 1., z__4.i = rkz;
  15292.     z__3.r = -z__4.r, z__3.i = -z__4.i;
  15293.     z__2.r = z__3.r * gz->r - z__3.i * gz->i, z__2.i = z__3.r * gz->i + 
  15294.         z__3.i * gz->r;
  15295.     z__1.r = z__2.r / r2, z__1.i = z__2.i / r2;
  15296.     gzp->r = z__1.r, gzp->i = z__1.i;
  15297. /*<       RETURN >*/
  15298.     return 0;
  15299. /*<       END >*/
  15300. } /* gx_ */
  15301.  
  15302. /* *** */
  15303. /*     DOUBLE PRECISION 6/4/85 */
  15304.  
  15305. /*<    >*/
  15306. /* Subroutine */ int gxx_(zz, rh, a, a2, xk, ira, g1, g1p, g2, g2p, g3, gzp)
  15307. doublereal *zz, *rh, *a, *a2, *xk;
  15308. integer *ira;
  15309. doublecomplex *g1, *g1p, *g2, *g2p, *g3, *gzp;
  15310. {
  15311.     /* System generated locals */
  15312.     doublereal d__1, d__2;
  15313.     doublecomplex z__1, z__2, z__3, z__4;
  15314.  
  15315.     /* Builtin functions */
  15316.     double sqrt(), cos(), sin();
  15317.  
  15318.     /* Local variables */
  15319.     static doublereal r;
  15320.     static doublecomplex c1, c2, c3;
  15321.     static doublereal r2, t1, r4, t2, rk;
  15322.     static doublecomplex gz;
  15323.     static doublereal rh2, rk2;
  15324.  
  15325. /* *** */
  15326. /*     SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX. */
  15327. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  15328. /*<       COMPLEX  GZ, C1, C2, C3, G1, G1P, G2, G2P, G3, GZP >*/
  15329. /*<       R2= ZZ* ZZ+ RH* RH >*/
  15330.     r2 = *zz * *zz + *rh * *rh;
  15331. /*<       R= SQRT( R2) >*/
  15332.     r = sqrt(r2);
  15333. /*<       R4= R2* R2 >*/
  15334.     r4 = r2 * r2;
  15335. /*<       RK= XK* R >*/
  15336.     rk = *xk * r;
  15337. /*<       RK2= RK* RK >*/
  15338.     rk2 = rk * rk;
  15339. /*<       RH2= RH* RH >*/
  15340.     rh2 = *rh * *rh;
  15341. /*<       T1=.25* A2* RH2/ R4 >*/
  15342.     d__1 = *a2 * .25;
  15343.     t1 = d__1 * rh2 / r4;
  15344. /*<       T2=.5* A2/ R2 >*/
  15345.     t2 = *a2 * .5 / r2;
  15346. /*<       C1= CMPLX(1.0, RK) >*/
  15347.     z__1.r = 1., z__1.i = rk;
  15348.     c1.r = z__1.r, c1.i = z__1.i;
  15349. /*<       C2=3.* C1- RK2 >*/
  15350.     z__2.r = c1.r * 3., z__2.i = c1.i * 3.;
  15351.     z__1.r = z__2.r - rk2, z__1.i = z__2.i;
  15352.     c2.r = z__1.r, c2.i = z__1.i;
  15353. /*<       C3= CMPLX(6.0, RK)* RK2-15.* C1 >*/
  15354.     z__3.r = 6., z__3.i = rk;
  15355.     z__2.r = rk2 * z__3.r, z__2.i = rk2 * z__3.i;
  15356.     z__4.r = c1.r * 15., z__4.i = c1.i * 15.;
  15357.     z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
  15358.     c3.r = z__1.r, c3.i = z__1.i;
  15359. /*<       GZ= CMPLX( COS( RK),- SIN( RK))/ R >*/
  15360.     d__1 = cos(rk);
  15361.     d__2 = -sin(rk);
  15362.     z__2.r = d__1, z__2.i = d__2;
  15363.     z__1.r = z__2.r / r, z__1.i = z__2.i / r;
  15364.     gz.r = z__1.r, gz.i = z__1.i;
  15365. /*<       G2= GZ*(1.+ T1* C2) >*/
  15366.     z__3.r = t1 * c2.r, z__3.i = t1 * c2.i;
  15367.     z__2.r = z__3.r + 1., z__2.i = z__3.i;
  15368.     z__1.r = gz.r * z__2.r - gz.i * z__2.i, z__1.i = gz.r * z__2.i + gz.i * 
  15369.         z__2.r;
  15370.     g2->r = z__1.r, g2->i = z__1.i;
  15371. /*<       G1= G2- T2* C1* GZ >*/
  15372.     z__3.r = t2 * c1.r, z__3.i = t2 * c1.i;
  15373.     z__2.r = z__3.r * gz.r - z__3.i * gz.i, z__2.i = z__3.r * gz.i + z__3.i * 
  15374.         gz.r;
  15375.     z__1.r = g2->r - z__2.r, z__1.i = g2->i - z__2.i;
  15376.     g1->r = z__1.r, g1->i = z__1.i;
  15377. /*<       GZ= GZ/ R2 >*/
  15378.     z__1.r = gz.r / r2, z__1.i = gz.i / r2;
  15379.     gz.r = z__1.r, gz.i = z__1.i;
  15380. /*<       G2P= GZ*( T1* C3- C1) >*/
  15381.     z__3.r = t1 * c3.r, z__3.i = t1 * c3.i;
  15382.     z__2.r = z__3.r - c1.r, z__2.i = z__3.i - c1.i;
  15383.     z__1.r = gz.r * z__2.r - gz.i * z__2.i, z__1.i = gz.r * z__2.i + gz.i * 
  15384.         z__2.r;
  15385.     g2p->r = z__1.r, g2p->i = z__1.i;
  15386. /*<       GZP= T2* C2* GZ >*/
  15387.     z__2.r = t2 * c2.r, z__2.i = t2 * c2.i;
  15388.     z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i * 
  15389.         gz.r;
  15390.     gzp->r = z__1.r, gzp->i = z__1.i;
  15391. /*<       G3= G2P+ GZP >*/
  15392.     z__1.r = g2p->r + gzp->r, z__1.i = g2p->i + gzp->i;
  15393.     g3->r = z__1.r, g3->i = z__1.i;
  15394. /*<       G1P= G3* ZZ >*/
  15395.     z__1.r = *zz * g3->r, z__1.i = *zz * g3->i;
  15396.     g1p->r = z__1.r, g1p->i = z__1.i;
  15397. /*<       IF( IRA.EQ.1) GOTO 2 >*/
  15398.     if (*ira == 1) {
  15399.     goto L2;
  15400.     }
  15401. /*<       G3=( G3+ GZP)* RH >*/
  15402.     z__2.r = g3->r + gzp->r, z__2.i = g3->i + gzp->i;
  15403.     z__1.r = *rh * z__2.r, z__1.i = *rh * z__2.i;
  15404.     g3->r = z__1.r, g3->i = z__1.i;
  15405. /*<       GZP=- ZZ* C1* GZ >*/
  15406.     d__1 = -(*zz);
  15407.     z__2.r = d__1 * c1.r, z__2.i = d__1 * c1.i;
  15408.     z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i * 
  15409.         gz.r;
  15410.     gzp->r = z__1.r, gzp->i = z__1.i;
  15411. /*<       IF( RH.GT.1.D-10) GOTO 1 >*/
  15412.     if (*rh > 1e-10) {
  15413.     goto L1;
  15414.     }
  15415. /*<       G2=0. >*/
  15416.     g2->r = 0., g2->i = 0.;
  15417. /*<       G2P=0. >*/
  15418.     g2p->r = 0., g2p->i = 0.;
  15419. /*<       RETURN >*/
  15420.     return 0;
  15421. /*<     1 G2= G2/ RH >*/
  15422. L1:
  15423.     z__1.r = g2->r / *rh, z__1.i = g2->i / *rh;
  15424.     g2->r = z__1.r, g2->i = z__1.i;
  15425. /*<       G2P= G2P* ZZ/ RH >*/
  15426.     z__2.r = *zz * g2p->r, z__2.i = *zz * g2p->i;
  15427.     z__1.r = z__2.r / *rh, z__1.i = z__2.i / *rh;
  15428.     g2p->r = z__1.r, g2p->i = z__1.i;
  15429. /*<       RETURN >*/
  15430.     return 0;
  15431. /*<     2 T2=.5* A >*/
  15432. L2:
  15433.     t2 = *a * .5;
  15434. /*<       G2=- T2* C1* GZ >*/
  15435.     d__1 = -t2;
  15436.     z__2.r = d__1 * c1.r, z__2.i = d__1 * c1.i;
  15437.     z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i * 
  15438.         gz.r;
  15439.     g2->r = z__1.r, g2->i = z__1.i;
  15440. /*<       G2P= T2* GZ* C2/ R2 >*/
  15441.     z__3.r = t2 * gz.r, z__3.i = t2 * gz.i;
  15442.     z__2.r = z__3.r * c2.r - z__3.i * c2.i, z__2.i = z__3.r * c2.i + z__3.i * 
  15443.         c2.r;
  15444.     z__1.r = z__2.r / r2, z__1.i = z__2.i / r2;
  15445.     g2p->r = z__1.r, g2p->i = z__1.i;
  15446. /*<       G3= RH2* G2P- A* GZ* C1 >*/
  15447.     z__2.r = rh2 * g2p->r, z__2.i = rh2 * g2p->i;
  15448.     z__4.r = *a * gz.r, z__4.i = *a * gz.i;
  15449.     z__3.r = z__4.r * c1.r - z__4.i * c1.i, z__3.i = z__4.r * c1.i + z__4.i * 
  15450.         c1.r;
  15451.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  15452.     g3->r = z__1.r, g3->i = z__1.i;
  15453. /*<       G2P= G2P* ZZ >*/
  15454.     z__1.r = *zz * g2p->r, z__1.i = *zz * g2p->i;
  15455.     g2p->r = z__1.r, g2p->i = z__1.i;
  15456. /*<       GZP=- ZZ* C1* GZ >*/
  15457.     d__1 = -(*zz);
  15458.     z__2.r = d__1 * c1.r, z__2.i = d__1 * c1.i;
  15459.     z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i * 
  15460.         gz.r;
  15461.     gzp->r = z__1.r, gzp->i = z__1.i;
  15462. /*<       RETURN >*/
  15463.     return 0;
  15464. /*<       END >*/
  15465. } /* gxx_ */
  15466.  
  15467. /* *** */
  15468. /*     DOUBLE PRECISION 6/4/85 */
  15469.  
  15470. /*<       SUBROUTINE HELIX( S, HL, A1, B1, A2, B2, RAD, NS, ITG) >*/
  15471. /* Subroutine */ int helix_(s, hl, a1, b1, a2, b2, rad, ns, itg)
  15472. doublereal *s, *hl, *a1, *b1, *a2, *b2, *rad;
  15473. integer *ns, *itg;
  15474. {
  15475.     /* Initialized data */
  15476.  
  15477.     static doublereal pi = 3.1415926;
  15478.  
  15479.     /* Format strings */
  15480.     static char fmt_104[] = "(5x,\002THE CONE ANGLE OF THE SPIRAL IS\002,f10\
  15481. .4)";
  15482.     static char fmt_105[] = "(5x,\002THE PITCH ANGLE IS\002,f10.4/5x,\002THE\
  15483.  LENGTH OF WIRE/TURN 'IS\002,f10.4)";
  15484.  
  15485.     /* System generated locals */
  15486.     integer i__1;
  15487.     doublereal d__1, d__2;
  15488.  
  15489.     /* Builtin functions */
  15490.     double cos(), sin(), atan();
  15491.     integer s_wsfe(), do_fio(), e_wsfe();
  15492.     double sqrt();
  15493.  
  15494.     /* Local variables */
  15495.     static doublereal hdia, hmaj, hmin, zinc, copy, turn;
  15496.     static integer i;
  15497.     static doublereal pitch;
  15498. #define x2 ((doublereal *)&data_1 + 1800)
  15499. #define y2 ((doublereal *)&data_1 + 3000)
  15500. #define z2 ((doublereal *)&data_1 + 3600)
  15501.     static doublereal turns, sangle;
  15502.     static integer ist;
  15503.  
  15504.     /* Fortran I/O blocks */
  15505.     static cilist io___1111 = { 0, 6, 0, fmt_104, 0 };
  15506.     static cilist io___1117 = { 0, 6, 0, fmt_105, 0 };
  15507.  
  15508.  
  15509. /* *** */
  15510. /*     SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS 
  15511. */
  15512. /*     SEGMENTS */
  15513. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  15514. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  15515. /*<    >*/
  15516. /*<       DIMENSION  X2(1), Y2(1), Z2(1) >*/
  15517. /*<       EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1)) >*/
  15518. /*<       DATA   PI/3.1415926D+0/ >*/
  15519. /*<       IST= N+1 >*/
  15520.     ist = data_1.n + 1;
  15521. /*<       N= N+ NS >*/
  15522.     data_1.n += *ns;
  15523. /*<       NP= N >*/
  15524.     data_1.np = data_1.n;
  15525. /*<       MP= M >*/
  15526.     data_1.mp = data_1.m;
  15527. /*<       IPSYM=0 >*/
  15528.     data_1.ipsym = 0;
  15529. /*<       IF( NS.LT.1) RETURN >*/
  15530.     if (*ns < 1) {
  15531.     return 0;
  15532.     }
  15533. /*<       TURNS= ABS( HL/ S) >*/
  15534.     turns = (d__1 = *hl / *s, abs(d__1));
  15535. /*<       ZINC= ABS( HL/ NS) >*/
  15536.     zinc = (d__1 = *hl / *ns, abs(d__1));
  15537. /*<       Z( IST)=0. >*/
  15538.     data_1.z[ist - 1] = 0.;
  15539. /*<       DO 25  I= IST, N >*/
  15540.     i__1 = data_1.n;
  15541.     for (i = ist; i <= i__1; ++i) {
  15542. /*<       BI( I)= RAD >*/
  15543.     data_1.bi[i - 1] = *rad;
  15544. /*<       ITAG( I)= ITG >*/
  15545.     data_1.itag[i - 1] = *itg;
  15546. /*<       IF( I.NE. IST) Z( I)= Z( I-1)+ ZINC >*/
  15547.     if (i != ist) {
  15548.         data_1.z[i - 1] = data_1.z[i - 2] + zinc;
  15549.     }
  15550. /*<       Z2( I)= Z( I)+ ZINC >*/
  15551.     z2[i - 1] = data_1.z[i - 1] + zinc;
  15552. /*<       IF( A2.NE. A1) GOTO 10 >*/
  15553.     if (*a2 != *a1) {
  15554.         goto L10;
  15555.     }
  15556. /*<       IF( B1.EQ.0) B1= A1 >*/
  15557.     if (*b1 == 0.) {
  15558.         *b1 = *a1;
  15559.     }
  15560. /*<       X( I)= A1* COS(2.* PI* Z( I)/ S) >*/
  15561.     d__1 = pi * 2.;
  15562.     data_1.x[i - 1] = *a1 * cos(d__1 * data_1.z[i - 1] / *s);
  15563. /*<       Y( I)= B1* SIN(2.* PI* Z( I)/ S) >*/
  15564.     d__1 = pi * 2.;
  15565.     data_1.y[i - 1] = *b1 * sin(d__1 * data_1.z[i - 1] / *s);
  15566. /*<       X2( I)= A1* COS(2.* PI* Z2( I)/ S) >*/
  15567.     d__1 = pi * 2.;
  15568.     x2[i - 1] = *a1 * cos(d__1 * z2[i - 1] / *s);
  15569. /*<       Y2( I)= B1* SIN(2.* PI* Z2( I)/ S) >*/
  15570.     d__1 = pi * 2.;
  15571.     y2[i - 1] = *b1 * sin(d__1 * z2[i - 1] / *s);
  15572. /*<       GOTO 20 >*/
  15573.     goto L20;
  15574. /*<    10 IF( B2.EQ.0) B2= A2 >*/
  15575. L10:
  15576.     if (*b2 == 0.) {
  15577.         *b2 = *a2;
  15578.     }
  15579. /*<       X( I)=( A1+( A2- A1)* Z( I)/ ABS( HL))* COS(2.* PI* Z( I)/ S) >*/
  15580.     d__1 = pi * 2.;
  15581.     data_1.x[i - 1] = (*a1 + (*a2 - *a1) * data_1.z[i - 1] / abs(*hl)) * 
  15582.         cos(d__1 * data_1.z[i - 1] / *s);
  15583. /*<       Y( I)=( B1+( B2- B1)* Z( I)/ ABS( HL))* SIN(2.* PI* Z( I)/ S) >*/
  15584.     d__1 = pi * 2.;
  15585.     data_1.y[i - 1] = (*b1 + (*b2 - *b1) * data_1.z[i - 1] / abs(*hl)) * 
  15586.         sin(d__1 * data_1.z[i - 1] / *s);
  15587. /*<       X2( I)=( A1+( A2- A1)* Z2( I)/ ABS( HL))* COS(2.* PI* Z2( I)/ S) >*/
  15588.     d__1 = pi * 2.;
  15589.     x2[i - 1] = (*a1 + (*a2 - *a1) * z2[i - 1] / abs(*hl)) * cos(d__1 * 
  15590.         z2[i - 1] / *s);
  15591. /*<       Y2( I)=( B1+( B2- B1)* Z2( I)/ ABS( HL))* SIN(2.* PI* Z2( I)/ S) >*/
  15592.     d__1 = pi * 2.;
  15593.     y2[i - 1] = (*b1 + (*b2 - *b1) * z2[i - 1] / abs(*hl)) * sin(d__1 * 
  15594.         z2[i - 1] / *s);
  15595. /*<    20 IF( HL.GT.0) GOTO 25 >*/
  15596. L20:
  15597.     if (*hl > 0.) {
  15598.         goto L25;
  15599.     }
  15600. /*<       COPY= X( I) >*/
  15601.     copy = data_1.x[i - 1];
  15602. /*<       X( I)= Y( I) >*/
  15603.     data_1.x[i - 1] = data_1.y[i - 1];
  15604. /*<       Y( I)= COPY >*/
  15605.     data_1.y[i - 1] = copy;
  15606. /*<       COPY= X2( I) >*/
  15607.     copy = x2[i - 1];
  15608. /*<       X2( I)= Y2( I) >*/
  15609.     x2[i - 1] = y2[i - 1];
  15610. /*<       Y2( I)= COPY >*/
  15611.     y2[i - 1] = copy;
  15612. /*<    25 CONTINUE >*/
  15613. L25:
  15614.     ;
  15615.     }
  15616. /*<       IF( A2.EQ. A1) GOTO 21 >*/
  15617.     if (*a2 == *a1) {
  15618.     goto L21;
  15619.     }
  15620. /*<       SANGLE= ATAN( A2/( ABS( HL)+( ABS( HL)* A1)/( A2- A1))) >*/
  15621.     sangle = atan(*a2 / (abs(*hl) + abs(*hl) * *a1 / (*a2 - *a1)));
  15622. /*<       WRITE( 6,104)  SANGLE >*/
  15623.     s_wsfe(&io___1111);
  15624.     do_fio(&c__1, (char *)&sangle, (ftnlen)sizeof(doublereal));
  15625.     e_wsfe();
  15626. /*<   104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4) >*/
  15627. /*<       RETURN >*/
  15628.     return 0;
  15629. /*<    21 IF( A1.NE. B1) GOTO 30 >*/
  15630. L21:
  15631.     if (*a1 != *b1) {
  15632.     goto L30;
  15633.     }
  15634. /*<       HDIA=2.* A1 >*/
  15635.     hdia = *a1 * 2.;
  15636. /*<       TURN= HDIA* PI >*/
  15637.     turn = hdia * pi;
  15638. /*<       PITCH= ATAN( S/( PI* HDIA)) >*/
  15639.     pitch = atan(*s / (pi * hdia));
  15640. /*<       TURN= TURN/ COS( PITCH) >*/
  15641.     turn /= cos(pitch);
  15642. /*<       PITCH=180.* PITCH/ PI >*/
  15643.     pitch = pitch * 180. / pi;
  15644. /*<       GOTO 40 >*/
  15645.     goto L40;
  15646. /*<    30 IF( A1.LT. B1) GOTO 34 >*/
  15647. L30:
  15648.     if (*a1 < *b1) {
  15649.     goto L34;
  15650.     }
  15651. /*<       HMAJ=2.* A1 >*/
  15652.     hmaj = *a1 * 2.;
  15653. /*<       HMIN=2.* B1 >*/
  15654.     hmin = *b1 * 2.;
  15655. /*<       GOTO 35 >*/
  15656.     goto L35;
  15657. /*<    34 HMAJ=2.* B1 >*/
  15658. L34:
  15659.     hmaj = *b1 * 2.;
  15660. /*<       HMIN=2.* A1 >*/
  15661.     hmin = *a1 * 2.;
  15662. /*<    35 HDIA= SQRT(( HMAJ**2+ HMIN**2)/2* HMAJ) >*/
  15663. L35:
  15664. /* Computing 2nd power */
  15665.     d__1 = hmaj;
  15666. /* Computing 2nd power */
  15667.     d__2 = hmin;
  15668.     hdia = sqrt((d__1 * d__1 + d__2 * d__2) / 2 * hmaj);
  15669. /*<       TURN=2.* PI* HDIA >*/
  15670.     d__1 = pi * 2.;
  15671.     turn = d__1 * hdia;
  15672. /*<       PITCH=(180./ PI)* ATAN( S/( PI* HDIA)) >*/
  15673.     pitch = 180. / pi * atan(*s / (pi * hdia));
  15674. /*<    40 WRITE( 6,105)  PITCH, TURN >*/
  15675. L40:
  15676.     s_wsfe(&io___1117);
  15677.     do_fio(&c__1, (char *)&pitch, (ftnlen)sizeof(doublereal));
  15678.     do_fio(&c__1, (char *)&turn, (ftnlen)sizeof(doublereal));
  15679.     e_wsfe();
  15680. /*<    >*/
  15681. /*<       RETURN >*/
  15682.     return 0;
  15683. /*<       END >*/
  15684. } /* helix_ */
  15685.  
  15686. #undef z2
  15687. #undef y2
  15688. #undef x2
  15689.  
  15690.  
  15691. /* *** */
  15692. /*     DOUBLE PRECISION 6/4/85 */
  15693.  
  15694. /*<       SUBROUTINE HFK( EL1, EL2, RHK, ZPKX, SGR, SGI) >*/
  15695. /* Subroutine */ int hfk_(el1, el2, rhk, zpkx, sgr, sgi)
  15696. doublereal *el1, *el2, *rhk, *zpkx, *sgr, *sgi;
  15697. {
  15698.     /* Initialized data */
  15699.  
  15700.     static integer nx = 1;
  15701.     static integer nm = 65536;
  15702.     static integer nts = 4;
  15703.     static doublereal rx = 1e-4;
  15704.  
  15705.     /* Format strings */
  15706.     static char fmt_18[] = "(\002 STEP SIZE LIMITED AT Z=\002,f10.5)";
  15707.  
  15708.     /* System generated locals */
  15709.     doublereal d__1;
  15710.  
  15711.     /* Builtin functions */
  15712.     integer s_wsfe(), do_fio(), e_wsfe();
  15713.  
  15714.     /* Local variables */
  15715.     static doublereal zend;
  15716.     extern /* Subroutine */ int test_();
  15717.     static doublereal dzot, s, z;
  15718.     extern /* Subroutine */ int gh_();
  15719.     static doublereal ep, dz, ze;
  15720.     static integer ns, nt;
  15721.     static doublereal zp, g1i, g3i, g5i, g2i, g4i, g1r, g2r, g3r, g4r, g5r, 
  15722.         t00i, t01i, t10i, t02i, t11i, t20i, t00r, t01r, t10r, t02r, t11r, 
  15723.         t20r, te1i, te2i, te1r, te2r;
  15724.  
  15725.     /* Fortran I/O blocks */
  15726.     static cilist io___1158 = { 0, 6, 0, fmt_18, 0 };
  15727.  
  15728.  
  15729. /* *** */
  15730. /*     HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BY */
  15731. /*     NUMERICAL INTEGRATION */
  15732. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  15733. /*<       COMMON  /TMH/ ZPK, RHKS >*/
  15734. /*<       DATA   NX, NM, NTS, RX/1,65536,4,1.D-4/ >*/
  15735. /*<       ZPK= ZPKX >*/
  15736.     tmh_1.zpk = *zpkx;
  15737. /*<       RHKS= RHK* RHK >*/
  15738.     tmh_1.rhks = *rhk * *rhk;
  15739. /*<       Z= EL1 >*/
  15740.     z = *el1;
  15741. /*<       ZE= EL2 >*/
  15742.     ze = *el2;
  15743. /*<       S= ZE- Z >*/
  15744.     s = ze - z;
  15745. /*<       EP= S/(10.* NM) >*/
  15746.     ep = s / (nm * 10.);
  15747. /*<       ZEND= ZE- EP >*/
  15748.     zend = ze - ep;
  15749. /*<       SGR=0.0 >*/
  15750.     *sgr = 0.;
  15751. /*<       SGI=0.0 >*/
  15752.     *sgi = 0.;
  15753. /*<       NS= NX >*/
  15754.     ns = nx;
  15755. /*<       NT=0 >*/
  15756.     nt = 0;
  15757. /*<       CALL GH( Z, G1R, G1I) >*/
  15758.     gh_(&z, &g1r, &g1i);
  15759. /*<     1 DZ= S/ NS >*/
  15760. L1:
  15761.     dz = s / ns;
  15762. /*<       ZP= Z+ DZ >*/
  15763.     zp = z + dz;
  15764. /*<       IF( ZP- ZE) 3,3,2 >*/
  15765.     if (zp - ze <= 0.) {
  15766.     goto L3;
  15767.     } else {
  15768.     goto L2;
  15769.     }
  15770. /*<     2 DZ= ZE- Z >*/
  15771. L2:
  15772.     dz = ze - z;
  15773. /*<       IF( ABS( DZ)- EP) 17,17,3 >*/
  15774.     if (abs(dz) - ep <= 0.) {
  15775.     goto L17;
  15776.     } else {
  15777.     goto L3;
  15778.     }
  15779. /*<     3 DZOT= DZ*.5 >*/
  15780. L3:
  15781.     dzot = dz * .5;
  15782. /*<       ZP= Z+ DZOT >*/
  15783.     zp = z + dzot;
  15784. /*<       CALL GH( ZP, G3R, G3I) >*/
  15785.     gh_(&zp, &g3r, &g3i);
  15786. /*<       ZP= Z+ DZ >*/
  15787.     zp = z + dz;
  15788. /*<       CALL GH( ZP, G5R, G5I) >*/
  15789.     gh_(&zp, &g5r, &g5i);
  15790. /*<     4 T00R=( G1R+ G5R)* DZOT >*/
  15791. L4:
  15792.     t00r = (g1r + g5r) * dzot;
  15793. /*<       T00I=( G1I+ G5I)* DZOT >*/
  15794.     t00i = (g1i + g5i) * dzot;
  15795. /*<       T01R=( T00R+ DZ* G3R)*0.5 >*/
  15796.     t01r = (t00r + dz * g3r) * .5;
  15797. /*<       T01I=( T00I+ DZ* G3I)*0.5 >*/
  15798.     t01i = (t00i + dz * g3i) * .5;
  15799. /*<       T10R=(4.0* T01R- T00R)/3.0 >*/
  15800.     t10r = (t01r * 4. - t00r) / 3.;
  15801. /*<       T10I=(4.0* T01I- T00I)/3.0 >*/
  15802.     t10i = (t01i * 4. - t00i) / 3.;
  15803. /*<       CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.) >*/
  15804.     test_(&t01r, &t10r, &te1r, &t01i, &t10i, &te1i, &c_b594);
  15805. /*<       IF( TE1I- RX) 5,5,6 >*/
  15806.     if (te1i - rx <= 0.) {
  15807.     goto L5;
  15808.     } else {
  15809.     goto L6;
  15810.     }
  15811. /*<     5 IF( TE1R- RX) 8,8,6 >*/
  15812. L5:
  15813.     if (te1r - rx <= 0.) {
  15814.     goto L8;
  15815.     } else {
  15816.     goto L6;
  15817.     }
  15818. /*<     6 ZP= Z+ DZ*0.25 >*/
  15819. L6:
  15820.     zp = z + dz * .25;
  15821. /*<       CALL GH( ZP, G2R, G2I) >*/
  15822.     gh_(&zp, &g2r, &g2i);
  15823. /*<       ZP= Z+ DZ*0.75 >*/
  15824.     zp = z + dz * .75;
  15825. /*<       CALL GH( ZP, G4R, G4I) >*/
  15826.     gh_(&zp, &g4r, &g4i);
  15827. /*<       T02R=( T01R+ DZOT*( G2R+ G4R))*0.5 >*/
  15828.     t02r = (t01r + dzot * (g2r + g4r)) * .5;
  15829. /*<       T02I=( T01I+ DZOT*( G2I+ G4I))*0.5 >*/
  15830.     t02i = (t01i + dzot * (g2i + g4i)) * .5;
  15831. /*<       T11R=(4.0* T02R- T01R)/3.0 >*/
  15832.     t11r = (t02r * 4. - t01r) / 3.;
  15833. /*<       T11I=(4.0* T02I- T01I)/3.0 >*/
  15834.     t11i = (t02i * 4. - t01i) / 3.;
  15835. /*<       T20R=(16.0* T11R- T10R)/15.0 >*/
  15836.     t20r = (t11r * 16. - t10r) / 15.;
  15837. /*<       T20I=(16.0* T11I- T10I)/15.0 >*/
  15838.     t20i = (t11i * 16. - t10i) / 15.;
  15839. /*<       CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.) >*/
  15840.     test_(&t11r, &t20r, &te2r, &t11i, &t20i, &te2i, &c_b594);
  15841. /*<       IF( TE2I- RX) 7,7,14 >*/
  15842.     if (te2i - rx <= 0.) {
  15843.     goto L7;
  15844.     } else {
  15845.     goto L14;
  15846.     }
  15847. /*<     7 IF( TE2R- RX) 9,9,14 >*/
  15848. L7:
  15849.     if (te2r - rx <= 0.) {
  15850.     goto L9;
  15851.     } else {
  15852.     goto L14;
  15853.     }
  15854. /*<     8 SGR= SGR+ T10R >*/
  15855. L8:
  15856.     *sgr += t10r;
  15857. /*<       SGI= SGI+ T10I >*/
  15858.     *sgi += t10i;
  15859. /*<       NT= NT+2 >*/
  15860.     nt += 2;
  15861. /*<       GOTO 10 >*/
  15862.     goto L10;
  15863. /*<     9 SGR= SGR+ T20R >*/
  15864. L9:
  15865.     *sgr += t20r;
  15866. /*<       SGI= SGI+ T20I >*/
  15867.     *sgi += t20i;
  15868. /*<       NT= NT+1 >*/
  15869.     ++nt;
  15870. /*<    10 Z= Z+ DZ >*/
  15871. L10:
  15872.     z += dz;
  15873. /*<       IF( Z- ZEND) 11,17,17 >*/
  15874.     if (z - zend >= 0.) {
  15875.     goto L17;
  15876.     } else {
  15877.     goto L11;
  15878.     }
  15879. /*<    11 G1R= G5R >*/
  15880. L11:
  15881.     g1r = g5r;
  15882. /*<       G1I= G5I >*/
  15883.     g1i = g5i;
  15884. /*<       IF( NT- NTS) 1,12,12 >*/
  15885.     if (nt - nts >= 0) {
  15886.     goto L12;
  15887.     } else {
  15888.     goto L1;
  15889.     }
  15890. /*<    12 IF( NS- NX) 1,1,13 >*/
  15891. L12:
  15892.     if (ns - nx <= 0) {
  15893.     goto L1;
  15894.     } else {
  15895.     goto L13;
  15896.     }
  15897. /*<    13 NS= NS/2 >*/
  15898. L13:
  15899.     ns /= 2;
  15900. /*<       NT=1 >*/
  15901.     nt = 1;
  15902. /*<       GOTO 1 >*/
  15903.     goto L1;
  15904. /*<    14 NT=0 >*/
  15905. L14:
  15906.     nt = 0;
  15907. /*<       IF( NS- NM) 16,15,15 >*/
  15908.     if (ns - nm >= 0) {
  15909.     goto L15;
  15910.     } else {
  15911.     goto L16;
  15912.     }
  15913. /*<    15 WRITE( 6,18)  Z >*/
  15914. L15:
  15915.     s_wsfe(&io___1158);
  15916.     do_fio(&c__1, (char *)&z, (ftnlen)sizeof(doublereal));
  15917.     e_wsfe();
  15918. /*<       GOTO 9 >*/
  15919.     goto L9;
  15920. /*<    16 NS= NS*2 >*/
  15921. L16:
  15922.     ns <<= 1;
  15923. /*<       DZ= S/ NS >*/
  15924.     dz = s / ns;
  15925. /*<       DZOT= DZ*0.5 >*/
  15926.     dzot = dz * .5;
  15927. /*<       G5R= G3R >*/
  15928.     g5r = g3r;
  15929. /*<       G5I= G3I >*/
  15930.     g5i = g3i;
  15931. /*<       G3R= G2R >*/
  15932.     g3r = g2r;
  15933. /*<       G3I= G2I >*/
  15934.     g3i = g2i;
  15935. /*<       GOTO 4 >*/
  15936.     goto L4;
  15937. /*<    17 CONTINUE >*/
  15938. L17:
  15939. /*<       SGR= SGR* RHK*.5 >*/
  15940.     d__1 = *sgr * *rhk;
  15941.     *sgr = d__1 * .5;
  15942. /*<       SGI= SGI* RHK*.5 >*/
  15943.     d__1 = *sgi * *rhk;
  15944.     *sgi = d__1 * .5;
  15945.  
  15946. /*<       RETURN >*/
  15947.     return 0;
  15948. /*<    18 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5) >*/
  15949. /*<       END >*/
  15950. } /* hfk_ */
  15951.  
  15952. /* *** */
  15953. /*     DOUBLE PRECISION 6/4/85 */
  15954.  
  15955. /*<       SUBROUTINE HINTG( XI, YI, ZI) >*/
  15956. /* Subroutine */ int hintg_(xi, yi, zi)
  15957. doublereal *xi, *yi, *zi;
  15958. {
  15959.     /* Initialized data */
  15960.  
  15961.     static doublereal fpi = 12.56637062;
  15962.     static doublereal tp = 6.283185308;
  15963.  
  15964.     /* System generated locals */
  15965.     integer i__1;
  15966.     doublereal d__1, d__2, d__3;
  15967.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
  15968.  
  15969.     /* Builtin functions */
  15970.     double sqrt(), cos(), sin();
  15971.     void z_sqrt(), z_div();
  15972.  
  15973.     /* Local variables */
  15974.     static doublereal t1zr, t2zr, r, xymag, cr;
  15975.     static integer ip;
  15976.     static doublereal rk, sr, px, rx, ry, rz, py;
  15977.     static doublecomplex f1x, f1y, f1z, f2x, f2y, f2z, gam;
  15978.     static doublereal cth, rfl;
  15979.     static doublecomplex rrh;
  15980.     static doublereal rsq;
  15981.     static doublecomplex rrv;
  15982. #define t1xj ((doublereal *)&dataj_1 + 5)
  15983. #define t1yj ((doublereal *)&dataj_1 + 6)
  15984. #define t1zj ((doublereal *)&dataj_1 + 7)
  15985. #define t2xj ((doublereal *)&dataj_1 + 1)
  15986. #define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
  15987. #define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
  15988.  
  15989. /* *** */
  15990. /*     HINTG COMPUTES THE H FIELD OF A PATCH CURRENT */
  15991. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  15992. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  15993. /*<    >*/
  15994. /*<    >*/
  15995. /*<    >*/
  15996. /*<    >*/
  15997. /*<       DATA   FPI/12.56637062D+0/, TP/6.283185308D+0/ >*/
  15998. /*<       RX= XI- XJ >*/
  15999.     rx = *xi - dataj_1.xj;
  16000. /*<       RY= YI- YJ >*/
  16001.     ry = *yi - dataj_1.yj;
  16002. /*<       RFL=-1. >*/
  16003.     rfl = -1.;
  16004. /*<       EXK=(0.,0.) >*/
  16005.     dataj_1.exk.r = 0., dataj_1.exk.i = 0.;
  16006. /*<       EYK=(0.,0.) >*/
  16007.     dataj_1.eyk.r = 0., dataj_1.eyk.i = 0.;
  16008. /*<       EZK=(0.,0.) >*/
  16009.     dataj_1.ezk.r = 0., dataj_1.ezk.i = 0.;
  16010. /*<       EXS=(0.,0.) >*/
  16011.     dataj_1.exs.r = 0., dataj_1.exs.i = 0.;
  16012. /*<       EYS=(0.,0.) >*/
  16013.     dataj_1.eys.r = 0., dataj_1.eys.i = 0.;
  16014. /*<       EZS=(0.,0.) >*/
  16015.     dataj_1.ezs.r = 0., dataj_1.ezs.i = 0.;
  16016. /*<       DO 5  IP=1, KSYMP >*/
  16017.     i__1 = gnd_1.ksymp;
  16018.     for (ip = 1; ip <= i__1; ++ip) {
  16019. /*<       RFL=- RFL >*/
  16020.     rfl = -rfl;
  16021. /*<       RZ= ZI- ZJ* RFL >*/
  16022.     rz = *zi - dataj_1.zj * rfl;
  16023. /*<       RSQ= RX* RX+ RY* RY+ RZ* RZ >*/
  16024.     d__1 = rx * rx + ry * ry;
  16025.     rsq = d__1 + rz * rz;
  16026. /*<       IF( RSQ.LT.1.D-20) GOTO 5 >*/
  16027.     if (rsq < 1e-20) {
  16028.         goto L5;
  16029.     }
  16030. /*<       R= SQRT( RSQ) >*/
  16031.     r = sqrt(rsq);
  16032. /*<       RK= TP* R >*/
  16033.     rk = tp * r;
  16034. /*<       CR= COS( RK) >*/
  16035.     cr = cos(rk);
  16036. /*<       SR= SIN( RK) >*/
  16037.     sr = sin(rk);
  16038. /*<       GAM=-( CMPLX( CR,- SR)+ RK* CMPLX( SR, CR))/( FPI* RSQ* R)* S >*/
  16039.     d__1 = -sr;
  16040.     z__5.r = cr, z__5.i = d__1;
  16041.     z__7.r = sr, z__7.i = cr;
  16042.     z__6.r = rk * z__7.r, z__6.i = rk * z__7.i;
  16043.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  16044.     z__3.r = -z__4.r, z__3.i = -z__4.i;
  16045.     d__3 = fpi * rsq;
  16046.     d__2 = d__3 * r;
  16047.     z__2.r = z__3.r / d__2, z__2.i = z__3.i / d__2;
  16048.     z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
  16049.     gam.r = z__1.r, gam.i = z__1.i;
  16050. /*<       EXC= GAM* RX >*/
  16051.     z__1.r = rx * gam.r, z__1.i = rx * gam.i;
  16052.     dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  16053. /*<       EYC= GAM* RY >*/
  16054.     z__1.r = ry * gam.r, z__1.i = ry * gam.i;
  16055.     dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
  16056. /*<       EZC= GAM* RZ >*/
  16057.     z__1.r = rz * gam.r, z__1.i = rz * gam.i;
  16058.     dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
  16059. /*<       T1ZR= T1ZJ* RFL >*/
  16060.     t1zr = *t1zj * rfl;
  16061. /*<       T2ZR= T2ZJ* RFL >*/
  16062.     t2zr = *t2zj * rfl;
  16063. /*<       F1X= EYC* T1ZR- EZC* T1YJ >*/
  16064.     z__2.r = t1zr * dataj_1.eyc.r, z__2.i = t1zr * dataj_1.eyc.i;
  16065.     z__3.r = *t1yj * dataj_1.ezc.r, z__3.i = *t1yj * dataj_1.ezc.i;
  16066.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  16067.     f1x.r = z__1.r, f1x.i = z__1.i;
  16068. /*<       F1Y= EZC* T1XJ- EXC* T1ZR >*/
  16069.     z__2.r = *t1xj * dataj_1.ezc.r, z__2.i = *t1xj * dataj_1.ezc.i;
  16070.     z__3.r = t1zr * dataj_1.exc.r, z__3.i = t1zr * dataj_1.exc.i;
  16071.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  16072.     f1y.r = z__1.r, f1y.i = z__1.i;
  16073. /*<       F1Z= EXC* T1YJ- EYC* T1XJ >*/
  16074.     z__2.r = *t1yj * dataj_1.exc.r, z__2.i = *t1yj * dataj_1.exc.i;
  16075.     z__3.r = *t1xj * dataj_1.eyc.r, z__3.i = *t1xj * dataj_1.eyc.i;
  16076.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  16077.     f1z.r = z__1.r, f1z.i = z__1.i;
  16078. /*<       F2X= EYC* T2ZR- EZC* T2YJ >*/
  16079.     z__2.r = t2zr * dataj_1.eyc.r, z__2.i = t2zr * dataj_1.eyc.i;
  16080.     z__3.r = *t2yj * dataj_1.ezc.r, z__3.i = *t2yj * dataj_1.ezc.i;
  16081.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  16082.     f2x.r = z__1.r, f2x.i = z__1.i;
  16083. /*<       F2Y= EZC* T2XJ- EXC* T2ZR >*/
  16084.     z__2.r = *t2xj * dataj_1.ezc.r, z__2.i = *t2xj * dataj_1.ezc.i;
  16085.     z__3.r = t2zr * dataj_1.exc.r, z__3.i = t2zr * dataj_1.exc.i;
  16086.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  16087.     f2y.r = z__1.r, f2y.i = z__1.i;
  16088. /*<       F2Z= EXC* T2YJ- EYC* T2XJ >*/
  16089.     z__2.r = *t2yj * dataj_1.exc.r, z__2.i = *t2yj * dataj_1.exc.i;
  16090.     z__3.r = *t2xj * dataj_1.eyc.r, z__3.i = *t2xj * dataj_1.eyc.i;
  16091.     z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
  16092.     f2z.r = z__1.r, f2z.i = z__1.i;
  16093. /*<       IF( IP.EQ.1) GOTO 4 >*/
  16094.     if (ip == 1) {
  16095.         goto L4;
  16096.     }
  16097. /*<       IF( IPERF.NE.1) GOTO 1 >*/
  16098.     if (gnd_1.iperf != 1) {
  16099.         goto L1;
  16100.     }
  16101. /*<       F1X=- F1X >*/
  16102.     z__1.r = -f1x.r, z__1.i = -f1x.i;
  16103.     f1x.r = z__1.r, f1x.i = z__1.i;
  16104. /*<       F1Y=- F1Y >*/
  16105.     z__1.r = -f1y.r, z__1.i = -f1y.i;
  16106.     f1y.r = z__1.r, f1y.i = z__1.i;
  16107. /*<       F1Z=- F1Z >*/
  16108.     z__1.r = -f1z.r, z__1.i = -f1z.i;
  16109.     f1z.r = z__1.r, f1z.i = z__1.i;
  16110. /*<       F2X=- F2X >*/
  16111.     z__1.r = -f2x.r, z__1.i = -f2x.i;
  16112.     f2x.r = z__1.r, f2x.i = z__1.i;
  16113. /*<       F2Y=- F2Y >*/
  16114.     z__1.r = -f2y.r, z__1.i = -f2y.i;
  16115.     f2y.r = z__1.r, f2y.i = z__1.i;
  16116. /*<       F2Z=- F2Z >*/
  16117.     z__1.r = -f2z.r, z__1.i = -f2z.i;
  16118.     f2z.r = z__1.r, f2z.i = z__1.i;
  16119. /*<       GOTO 4 >*/
  16120.     goto L4;
  16121. /*<     1 XYMAG= SQRT( RX* RX+ RY* RY) >*/
  16122. L1:
  16123.     xymag = sqrt(rx * rx + ry * ry);
  16124. /*<       IF( XYMAG.GT.1.D-6) GOTO 2 >*/
  16125.     if (xymag > 1e-6) {
  16126.         goto L2;
  16127.     }
  16128. /*<       PX=0. >*/
  16129.     px = 0.;
  16130. /*<       PY=0. >*/
  16131.     py = 0.;
  16132. /*<       CTH=1. >*/
  16133.     cth = 1.;
  16134. /*<       RRV=(1.,0.) >*/
  16135.     rrv.r = 1., rrv.i = 0.;
  16136. /*<       GOTO 3 >*/
  16137.     goto L3;
  16138. /*<     2 PX=- RY/ XYMAG >*/
  16139. L2:
  16140.     px = -ry / xymag;
  16141. /*<       PY= RX/ XYMAG >*/
  16142.     py = rx / xymag;
  16143. /*<       CTH= RZ/ R >*/
  16144.     cth = rz / r;
  16145. /*<       RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH)) >*/
  16146.     z__4.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i * 
  16147.         gnd_1.zrati.i, z__4.i = gnd_1.zrati.r * gnd_1.zrati.i + 
  16148.         gnd_1.zrati.i * gnd_1.zrati.r;
  16149.     d__1 = 1. - cth * cth;
  16150.     z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
  16151.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  16152.     z_sqrt(&z__1, &z__2);
  16153.     rrv.r = z__1.r, rrv.i = z__1.i;
  16154. /*<     3 RRH= ZRATI* CTH >*/
  16155. L3:
  16156.     z__1.r = cth * gnd_1.zrati.r, z__1.i = cth * gnd_1.zrati.i;
  16157.     rrh.r = z__1.r, rrh.i = z__1.i;
  16158. /*<       RRH=( RRH- RRV)/( RRH+ RRV) >*/
  16159.     z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
  16160.     z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
  16161.     z_div(&z__1, &z__2, &z__3);
  16162.     rrh.r = z__1.r, rrh.i = z__1.i;
  16163. /*<       RRV= ZRATI* RRV >*/
  16164.     z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i = 
  16165.         gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
  16166.     rrv.r = z__1.r, rrv.i = z__1.i;
  16167. /*<       RRV=-( CTH- RRV)/( CTH+ RRV) >*/
  16168.     z__3.r = cth - rrv.r, z__3.i = -rrv.i;
  16169.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  16170.     z__4.r = cth + rrv.r, z__4.i = rrv.i;
  16171.     z_div(&z__1, &z__2, &z__4);
  16172.     rrv.r = z__1.r, rrv.i = z__1.i;
  16173. /*<       GAM=( F1X* PX+ F1Y* PY)*( RRV- RRH) >*/
  16174.     z__3.r = px * f1x.r, z__3.i = px * f1x.i;
  16175.     z__4.r = py * f1y.r, z__4.i = py * f1y.i;
  16176.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  16177.     z__5.r = rrv.r - rrh.r, z__5.i = rrv.i - rrh.i;
  16178.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i 
  16179.         + z__2.i * z__5.r;
  16180.     gam.r = z__1.r, gam.i = z__1.i;
  16181. /*<       F1X= F1X* RRH+ GAM* PX >*/
  16182.     z__2.r = f1x.r * rrh.r - f1x.i * rrh.i, z__2.i = f1x.r * rrh.i + 
  16183.         f1x.i * rrh.r;
  16184.     z__3.r = px * gam.r, z__3.i = px * gam.i;
  16185.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  16186.     f1x.r = z__1.r, f1x.i = z__1.i;
  16187. /*<       F1Y= F1Y* RRH+ GAM* PY >*/
  16188.     z__2.r = f1y.r * rrh.r - f1y.i * rrh.i, z__2.i = f1y.r * rrh.i + 
  16189.         f1y.i * rrh.r;
  16190.     z__3.r = py * gam.r, z__3.i = py * gam.i;
  16191.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  16192.     f1y.r = z__1.r, f1y.i = z__1.i;
  16193. /*<       F1Z= F1Z* RRH >*/
  16194.     z__1.r = f1z.r * rrh.r - f1z.i * rrh.i, z__1.i = f1z.r * rrh.i + 
  16195.         f1z.i * rrh.r;
  16196.     f1z.r = z__1.r, f1z.i = z__1.i;
  16197. /*<       GAM=( F2X* PX+ F2Y* PY)*( RRV- RRH) >*/
  16198.     z__3.r = px * f2x.r, z__3.i = px * f2x.i;
  16199.     z__4.r = py * f2y.r, z__4.i = py * f2y.i;
  16200.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  16201.     z__5.r = rrv.r - rrh.r, z__5.i = rrv.i - rrh.i;
  16202.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i 
  16203.         + z__2.i * z__5.r;
  16204.     gam.r = z__1.r, gam.i = z__1.i;
  16205. /*<       F2X= F2X* RRH+ GAM* PX >*/
  16206.     z__2.r = f2x.r * rrh.r - f2x.i * rrh.i, z__2.i = f2x.r * rrh.i + 
  16207.         f2x.i * rrh.r;
  16208.     z__3.r = px * gam.r, z__3.i = px * gam.i;
  16209.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  16210.     f2x.r = z__1.r, f2x.i = z__1.i;
  16211. /*<       F2Y= F2Y* RRH+ GAM* PY >*/
  16212.     z__2.r = f2y.r * rrh.r - f2y.i * rrh.i, z__2.i = f2y.r * rrh.i + 
  16213.         f2y.i * rrh.r;
  16214.     z__3.r = py * gam.r, z__3.i = py * gam.i;
  16215.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  16216.     f2y.r = z__1.r, f2y.i = z__1.i;
  16217. /*<       F2Z= F2Z* RRH >*/
  16218.     z__1.r = f2z.r * rrh.r - f2z.i * rrh.i, z__1.i = f2z.r * rrh.i + 
  16219.         f2z.i * rrh.r;
  16220.     f2z.r = z__1.r, f2z.i = z__1.i;
  16221. /*<     4 EXK= EXK+ F1X >*/
  16222. L4:
  16223.     z__1.r = dataj_1.exk.r + f1x.r, z__1.i = dataj_1.exk.i + f1x.i;
  16224.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  16225. /*<       EYK= EYK+ F1Y >*/
  16226.     z__1.r = dataj_1.eyk.r + f1y.r, z__1.i = dataj_1.eyk.i + f1y.i;
  16227.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  16228. /*<       EZK= EZK+ F1Z >*/
  16229.     z__1.r = dataj_1.ezk.r + f1z.r, z__1.i = dataj_1.ezk.i + f1z.i;
  16230.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  16231. /*<       EXS= EXS+ F2X >*/
  16232.     z__1.r = dataj_1.exs.r + f2x.r, z__1.i = dataj_1.exs.i + f2x.i;
  16233.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  16234. /*<       EYS= EYS+ F2Y >*/
  16235.     z__1.r = dataj_1.eys.r + f2y.r, z__1.i = dataj_1.eys.i + f2y.i;
  16236.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  16237. /*<       EZS= EZS+ F2Z >*/
  16238.     z__1.r = dataj_1.ezs.r + f2z.r, z__1.i = dataj_1.ezs.i + f2z.i;
  16239.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  16240. /*<     5 CONTINUE >*/
  16241. L5:
  16242.     ;
  16243.     }
  16244. /*<       RETURN >*/
  16245.     return 0;
  16246. /*<       END >*/
  16247. } /* hintg_ */
  16248.  
  16249. #undef t2zj
  16250. #undef t2yj
  16251. #undef t2xj
  16252. #undef t1zj
  16253. #undef t1yj
  16254. #undef t1xj
  16255.  
  16256.  
  16257. /* *** */
  16258. /*     DOUBLE PRECISION 6/4/85 */
  16259.  
  16260. /*<       SUBROUTINE HSFLD( XI, YI, ZI, AI) >*/
  16261. /* Subroutine */ int hsfld_(xi, yi, zi, ai)
  16262. doublereal *xi, *yi, *zi, *ai;
  16263. {
  16264.     /* Initialized data */
  16265.  
  16266.     static doublereal eta = 376.73;
  16267.  
  16268.     /* System generated locals */
  16269.     integer i__1;
  16270.     doublereal d__1, d__2;
  16271.     doublecomplex z__1, z__2, z__3, z__4;
  16272.  
  16273.     /* Builtin functions */
  16274.     double sqrt(), log();
  16275.     void z_div(), z_sqrt();
  16276.  
  16277.     /* Local variables */
  16278.     static doublereal rmag, rhox, rhoy, rhoz, salpr, xspec, yspec;
  16279.     extern /* Subroutine */ int hsflx_();
  16280.     static doublereal xymag;
  16281.     static doublecomplex zratx;
  16282.     static integer ip;
  16283.     static doublereal rh, px;
  16284.     static doublecomplex qx, qy, qz;
  16285.     static doublereal zp, py, rhospc;
  16286.     static doublecomplex hpc;
  16287.     static doublereal cth;
  16288.     static doublecomplex hpk;
  16289.     static doublereal rfl;
  16290.     static doublecomplex hps, rrh;
  16291.     static doublereal xij, yij, zij, phx, phy, phz;
  16292.     static doublecomplex rrv;
  16293.  
  16294. /* *** */
  16295. /*     HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT 
  16296. */
  16297. /*     ON A SEGMENT INCLUDING GROUND EFFECTS. */
  16298. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  16299. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  16300. /*<    >*/
  16301. /*<    >*/
  16302. /*<    >*/
  16303. /*<       DATA   ETA/376.73/ >*/
  16304. /*<       XIJ= XI- XJ >*/
  16305.     xij = *xi - dataj_1.xj;
  16306. /*<       YIJ= YI- YJ >*/
  16307.     yij = *yi - dataj_1.yj;
  16308. /*<       RFL=-1. >*/
  16309.     rfl = -1.;
  16310. /*<       DO 7  IP=1, KSYMP >*/
  16311.     i__1 = gnd_1.ksymp;
  16312.     for (ip = 1; ip <= i__1; ++ip) {
  16313. /*<       RFL=- RFL >*/
  16314.     rfl = -rfl;
  16315. /*<       SALPR= SALPJ* RFL >*/
  16316.     salpr = dataj_1.salpj * rfl;
  16317. /*<       ZIJ= ZI- RFL* ZJ >*/
  16318.     zij = *zi - rfl * dataj_1.zj;
  16319. /*<       ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR >*/
  16320.     d__1 = xij * dataj_1.cabj + yij * dataj_1.sabj;
  16321.     zp = d__1 + zij * salpr;
  16322. /*<       RHOX= XIJ- CABJ* ZP >*/
  16323.     rhox = xij - dataj_1.cabj * zp;
  16324. /*<       RHOY= YIJ- SABJ* ZP >*/
  16325.     rhoy = yij - dataj_1.sabj * zp;
  16326. /*<       RHOZ= ZIJ- SALPR* ZP >*/
  16327.     rhoz = zij - salpr * zp;
  16328. /*<       RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI) >*/
  16329.     d__2 = rhox * rhox + rhoy * rhoy;
  16330.     d__1 = d__2 + rhoz * rhoz;
  16331.     rh = sqrt(d__1 + *ai * *ai);
  16332. /*<       IF( RH.GT.1.D-10) GOTO 1 >*/
  16333.     if (rh > 1e-10) {
  16334.         goto L1;
  16335.     }
  16336. /*<       EXK=0. >*/
  16337.     dataj_1.exk.r = 0., dataj_1.exk.i = 0.;
  16338. /*<       EYK=0. >*/
  16339.     dataj_1.eyk.r = 0., dataj_1.eyk.i = 0.;
  16340. /*<       EZK=0. >*/
  16341.     dataj_1.ezk.r = 0., dataj_1.ezk.i = 0.;
  16342. /*<       EXS=0. >*/
  16343.     dataj_1.exs.r = 0., dataj_1.exs.i = 0.;
  16344. /*<       EYS=0. >*/
  16345.     dataj_1.eys.r = 0., dataj_1.eys.i = 0.;
  16346. /*<       EZS=0. >*/
  16347.     dataj_1.ezs.r = 0., dataj_1.ezs.i = 0.;
  16348. /*<       EXC=0. >*/
  16349.     dataj_1.exc.r = 0., dataj_1.exc.i = 0.;
  16350. /*<       EYC=0. >*/
  16351.     dataj_1.eyc.r = 0., dataj_1.eyc.i = 0.;
  16352. /*<       EZC=0. >*/
  16353.     dataj_1.ezc.r = 0., dataj_1.ezc.i = 0.;
  16354. /*<       GOTO 7 >*/
  16355.     goto L7;
  16356. /*<     1 RHOX= RHOX/ RH >*/
  16357. L1:
  16358.     rhox /= rh;
  16359. /*<       RHOY= RHOY/ RH >*/
  16360.     rhoy /= rh;
  16361. /*<       RHOZ= RHOZ/ RH >*/
  16362.     rhoz /= rh;
  16363. /*<       PHX= SABJ* RHOZ- SALPR* RHOY >*/
  16364.     phx = dataj_1.sabj * rhoz - salpr * rhoy;
  16365. /*<       PHY= SALPR* RHOX- CABJ* RHOZ >*/
  16366.     phy = salpr * rhox - dataj_1.cabj * rhoz;
  16367. /*<       PHZ= CABJ* RHOY- SABJ* RHOX >*/
  16368.     phz = dataj_1.cabj * rhoy - dataj_1.sabj * rhox;
  16369. /*<       CALL HSFLX( S, RH, ZP, HPK, HPS, HPC) >*/
  16370.     hsflx_(&dataj_1.s, &rh, &zp, &hpk, &hps, &hpc);
  16371. /*<       IF( IP.NE.2) GOTO 6 >*/
  16372.     if (ip != 2) {
  16373.         goto L6;
  16374.     }
  16375. /*<       IF( IPERF.EQ.1) GOTO 5 >*/
  16376.     if (gnd_1.iperf == 1) {
  16377.         goto L5;
  16378.     }
  16379. /*<       ZRATX= ZRATI >*/
  16380.     zratx.r = gnd_1.zrati.r, zratx.i = gnd_1.zrati.i;
  16381. /*<       RMAG= SQRT( ZP* ZP+ RH* RH) >*/
  16382.     rmag = sqrt(zp * zp + rh * rh);
  16383.  
  16384. /*     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN. */
  16385.  
  16386. /*<       XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ) >*/
  16387.     xymag = sqrt(xij * xij + yij * yij);
  16388. /*<       IF( NRADL.EQ.0) GOTO 2 >*/
  16389.     if (gnd_1.nradl == 0) {
  16390.         goto L2;
  16391.     }
  16392. /*<       XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ) >*/
  16393.     xspec = (*xi * dataj_1.zj + *zi * dataj_1.xj) / (*zi + dataj_1.zj);
  16394. /*<       YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ) >*/
  16395.     yspec = (*yi * dataj_1.zj + *zi * dataj_1.yj) / (*zi + dataj_1.zj);
  16396. /*<       RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2) >*/
  16397.     d__1 = xspec * xspec + yspec * yspec;
  16398.     rhospc = sqrt(d__1 + gnd_1.t2 * gnd_1.t2);
  16399. /*<       IF( RHOSPC.GT. SCRWL) GOTO 2 >*/
  16400.     if (rhospc > gnd_1.scrwl) {
  16401.         goto L2;
  16402.     }
  16403. /*<       RRV= T1* RHOSPC* LOG( RHOSPC/ T2) >*/
  16404.     z__2.r = rhospc * gnd_1.t1.r, z__2.i = rhospc * gnd_1.t1.i;
  16405.     d__1 = log(rhospc / gnd_1.t2);
  16406.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  16407.     rrv.r = z__1.r, rrv.i = z__1.i;
  16408. /*<       ZRATX=( RRV* ZRATI)/( ETA* ZRATI+ RRV) >*/
  16409.     z__2.r = rrv.r * gnd_1.zrati.r - rrv.i * gnd_1.zrati.i, z__2.i = 
  16410.         rrv.r * gnd_1.zrati.i + rrv.i * gnd_1.zrati.r;
  16411.     z__4.r = eta * gnd_1.zrati.r, z__4.i = eta * gnd_1.zrati.i;
  16412.     z__3.r = z__4.r + rrv.r, z__3.i = z__4.i + rrv.i;
  16413.     z_div(&z__1, &z__2, &z__3);
  16414.     zratx.r = z__1.r, zratx.i = z__1.i;
  16415.  
  16416. /*     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED
  16417. . */
  16418.  
  16419. /*<     2 IF( XYMAG.GT.1.D-6) GOTO 3 >*/
  16420. L2:
  16421.     if (xymag > 1e-6) {
  16422.         goto L3;
  16423.     }
  16424. /*<       PX=0. >*/
  16425.     px = 0.;
  16426. /*<       PY=0. >*/
  16427.     py = 0.;
  16428. /*<       CTH=1. >*/
  16429.     cth = 1.;
  16430. /*<       RRV=(1.,0.) >*/
  16431.     rrv.r = 1., rrv.i = 0.;
  16432. /*<       GOTO 4 >*/
  16433.     goto L4;
  16434. /*<     3 PX=- YIJ/ XYMAG >*/
  16435. L3:
  16436.     px = -yij / xymag;
  16437. /*<       PY= XIJ/ XYMAG >*/
  16438.     py = xij / xymag;
  16439. /*<       CTH= ZIJ/ RMAG >*/
  16440.     cth = zij / rmag;
  16441. /*<       RRV= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH)) >*/
  16442.     z__4.r = zratx.r * zratx.r - zratx.i * zratx.i, z__4.i = zratx.r * 
  16443.         zratx.i + zratx.i * zratx.r;
  16444.     d__1 = 1. - cth * cth;
  16445.     z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
  16446.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  16447.     z_sqrt(&z__1, &z__2);
  16448.     rrv.r = z__1.r, rrv.i = z__1.i;
  16449. /*<     4 RRH= ZRATX* CTH >*/
  16450. L4:
  16451.     z__1.r = cth * zratx.r, z__1.i = cth * zratx.i;
  16452.     rrh.r = z__1.r, rrh.i = z__1.i;
  16453. /*<       RRH=-( RRH- RRV)/( RRH+ RRV) >*/
  16454.     z__3.r = rrh.r - rrv.r, z__3.i = rrh.i - rrv.i;
  16455.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  16456.     z__4.r = rrh.r + rrv.r, z__4.i = rrh.i + rrv.i;
  16457.     z_div(&z__1, &z__2, &z__4);
  16458.     rrh.r = z__1.r, rrh.i = z__1.i;
  16459. /*<       RRV= ZRATX* RRV >*/
  16460.     z__1.r = zratx.r * rrv.r - zratx.i * rrv.i, z__1.i = zratx.r * rrv.i 
  16461.         + zratx.i * rrv.r;
  16462.     rrv.r = z__1.r, rrv.i = z__1.i;
  16463. /*<       RRV=( CTH- RRV)/( CTH+ RRV) >*/
  16464.     z__2.r = cth - rrv.r, z__2.i = -rrv.i;
  16465.     z__3.r = cth + rrv.r, z__3.i = rrv.i;
  16466.     z_div(&z__1, &z__2, &z__3);
  16467.     rrv.r = z__1.r, rrv.i = z__1.i;
  16468. /*<       QY=( PHX* PX+ PHY* PY)*( RRV- RRH) >*/
  16469.     d__1 = phx * px + phy * py;
  16470.     z__2.r = rrv.r - rrh.r, z__2.i = rrv.i - rrh.i;
  16471.     z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
  16472.     qy.r = z__1.r, qy.i = z__1.i;
  16473. /*<       QX= QY* PX+ PHX* RRH >*/
  16474.     z__2.r = px * qy.r, z__2.i = px * qy.i;
  16475.     z__3.r = phx * rrh.r, z__3.i = phx * rrh.i;
  16476.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  16477.     qx.r = z__1.r, qx.i = z__1.i;
  16478. /*<       QY= QY* PY+ PHY* RRH >*/
  16479.     z__2.r = py * qy.r, z__2.i = py * qy.i;
  16480.     z__3.r = phy * rrh.r, z__3.i = phy * rrh.i;
  16481.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  16482.     qy.r = z__1.r, qy.i = z__1.i;
  16483. /*<       QZ= PHZ* RRH >*/
  16484.     z__1.r = phz * rrh.r, z__1.i = phz * rrh.i;
  16485.     qz.r = z__1.r, qz.i = z__1.i;
  16486. /*<       EXK= EXK- HPK* QX >*/
  16487.     z__2.r = hpk.r * qx.r - hpk.i * qx.i, z__2.i = hpk.r * qx.i + hpk.i * 
  16488.         qx.r;
  16489.     z__1.r = dataj_1.exk.r - z__2.r, z__1.i = dataj_1.exk.i - z__2.i;
  16490.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  16491. /*<       EYK= EYK- HPK* QY >*/
  16492.     z__2.r = hpk.r * qy.r - hpk.i * qy.i, z__2.i = hpk.r * qy.i + hpk.i * 
  16493.         qy.r;
  16494.     z__1.r = dataj_1.eyk.r - z__2.r, z__1.i = dataj_1.eyk.i - z__2.i;
  16495.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  16496. /*<       EZK= EZK- HPK* QZ >*/
  16497.     z__2.r = hpk.r * qz.r - hpk.i * qz.i, z__2.i = hpk.r * qz.i + hpk.i * 
  16498.         qz.r;
  16499.     z__1.r = dataj_1.ezk.r - z__2.r, z__1.i = dataj_1.ezk.i - z__2.i;
  16500.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  16501. /*<       EXS= EXS- HPS* QX >*/
  16502.     z__2.r = hps.r * qx.r - hps.i * qx.i, z__2.i = hps.r * qx.i + hps.i * 
  16503.         qx.r;
  16504.     z__1.r = dataj_1.exs.r - z__2.r, z__1.i = dataj_1.exs.i - z__2.i;
  16505.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  16506. /*<       EYS= EYS- HPS* QY >*/
  16507.     z__2.r = hps.r * qy.r - hps.i * qy.i, z__2.i = hps.r * qy.i + hps.i * 
  16508.         qy.r;
  16509.     z__1.r = dataj_1.eys.r - z__2.r, z__1.i = dataj_1.eys.i - z__2.i;
  16510.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  16511. /*<       EZS= EZS- HPS* QZ >*/
  16512.     z__2.r = hps.r * qz.r - hps.i * qz.i, z__2.i = hps.r * qz.i + hps.i * 
  16513.         qz.r;
  16514.     z__1.r = dataj_1.ezs.r - z__2.r, z__1.i = dataj_1.ezs.i - z__2.i;
  16515.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  16516. /*<       EXC= EXC- HPC* QX >*/
  16517.     z__2.r = hpc.r * qx.r - hpc.i * qx.i, z__2.i = hpc.r * qx.i + hpc.i * 
  16518.         qx.r;
  16519.     z__1.r = dataj_1.exc.r - z__2.r, z__1.i = dataj_1.exc.i - z__2.i;
  16520.     dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  16521. /*<       EYC= EYC- HPC* QY >*/
  16522.     z__2.r = hpc.r * qy.r - hpc.i * qy.i, z__2.i = hpc.r * qy.i + hpc.i * 
  16523.         qy.r;
  16524.     z__1.r = dataj_1.eyc.r - z__2.r, z__1.i = dataj_1.eyc.i - z__2.i;
  16525.     dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
  16526. /*<       EZC= EZC- HPC* QZ >*/
  16527.     z__2.r = hpc.r * qz.r - hpc.i * qz.i, z__2.i = hpc.r * qz.i + hpc.i * 
  16528.         qz.r;
  16529.     z__1.r = dataj_1.ezc.r - z__2.r, z__1.i = dataj_1.ezc.i - z__2.i;
  16530.     dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
  16531. /*<       GOTO 7 >*/
  16532.     goto L7;
  16533. /*<     5 EXK= EXK- HPK* PHX >*/
  16534. L5:
  16535.     z__2.r = phx * hpk.r, z__2.i = phx * hpk.i;
  16536.     z__1.r = dataj_1.exk.r - z__2.r, z__1.i = dataj_1.exk.i - z__2.i;
  16537.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  16538. /*<       EYK= EYK- HPK* PHY >*/
  16539.     z__2.r = phy * hpk.r, z__2.i = phy * hpk.i;
  16540.     z__1.r = dataj_1.eyk.r - z__2.r, z__1.i = dataj_1.eyk.i - z__2.i;
  16541.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  16542. /*<       EZK= EZK- HPK* PHZ >*/
  16543.     z__2.r = phz * hpk.r, z__2.i = phz * hpk.i;
  16544.     z__1.r = dataj_1.ezk.r - z__2.r, z__1.i = dataj_1.ezk.i - z__2.i;
  16545.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  16546. /*<       EXS= EXS- HPS* PHX >*/
  16547.     z__2.r = phx * hps.r, z__2.i = phx * hps.i;
  16548.     z__1.r = dataj_1.exs.r - z__2.r, z__1.i = dataj_1.exs.i - z__2.i;
  16549.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  16550. /*<       EYS= EYS- HPS* PHY >*/
  16551.     z__2.r = phy * hps.r, z__2.i = phy * hps.i;
  16552.     z__1.r = dataj_1.eys.r - z__2.r, z__1.i = dataj_1.eys.i - z__2.i;
  16553.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  16554. /*<       EZS= EZS- HPS* PHZ >*/
  16555.     z__2.r = phz * hps.r, z__2.i = phz * hps.i;
  16556.     z__1.r = dataj_1.ezs.r - z__2.r, z__1.i = dataj_1.ezs.i - z__2.i;
  16557.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  16558. /*<       EXC= EXC- HPC* PHX >*/
  16559.     z__2.r = phx * hpc.r, z__2.i = phx * hpc.i;
  16560.     z__1.r = dataj_1.exc.r - z__2.r, z__1.i = dataj_1.exc.i - z__2.i;
  16561.     dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  16562. /*<       EYC= EYC- HPC* PHY >*/
  16563.     z__2.r = phy * hpc.r, z__2.i = phy * hpc.i;
  16564.     z__1.r = dataj_1.eyc.r - z__2.r, z__1.i = dataj_1.eyc.i - z__2.i;
  16565.     dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
  16566. /*<       EZC= EZC- HPC* PHZ >*/
  16567.     z__2.r = phz * hpc.r, z__2.i = phz * hpc.i;
  16568.     z__1.r = dataj_1.ezc.r - z__2.r, z__1.i = dataj_1.ezc.i - z__2.i;
  16569.     dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
  16570. /*<       GOTO 7 >*/
  16571.     goto L7;
  16572. /*<     6 EXK= HPK* PHX >*/
  16573. L6:
  16574.     z__1.r = phx * hpk.r, z__1.i = phx * hpk.i;
  16575.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  16576. /*<       EYK= HPK* PHY >*/
  16577.     z__1.r = phy * hpk.r, z__1.i = phy * hpk.i;
  16578.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  16579. /*<       EZK= HPK* PHZ >*/
  16580.     z__1.r = phz * hpk.r, z__1.i = phz * hpk.i;
  16581.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  16582. /*<       EXS= HPS* PHX >*/
  16583.     z__1.r = phx * hps.r, z__1.i = phx * hps.i;
  16584.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  16585. /*<       EYS= HPS* PHY >*/
  16586.     z__1.r = phy * hps.r, z__1.i = phy * hps.i;
  16587.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  16588. /*<       EZS= HPS* PHZ >*/
  16589.     z__1.r = phz * hps.r, z__1.i = phz * hps.i;
  16590.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  16591. /*<       EXC= HPC* PHX >*/
  16592.     z__1.r = phx * hpc.r, z__1.i = phx * hpc.i;
  16593.     dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
  16594. /*<       EYC= HPC* PHY >*/
  16595.     z__1.r = phy * hpc.r, z__1.i = phy * hpc.i;
  16596.     dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
  16597. /*<       EZC= HPC* PHZ >*/
  16598.     z__1.r = phz * hpc.r, z__1.i = phz * hpc.i;
  16599.     dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
  16600. /*<     7 CONTINUE >*/
  16601. L7:
  16602.     ;
  16603.     }
  16604. /*<       RETURN >*/
  16605.     return 0;
  16606. /*<       END >*/
  16607. } /* hsfld_ */
  16608.  
  16609. /* *** */
  16610. /*     DOUBLE PRECISION 6/4/85 */
  16611.  
  16612. /*<       SUBROUTINE HSFLX( S, RH, ZPX, HPK, HPS, HPC) >*/
  16613. /* Subroutine */ int hsflx_(s, rh, zpx, hpk, hps, hpc)
  16614. doublereal *s, *rh, *zpx;
  16615. doublecomplex *hpk, *hps, *hpc;
  16616. {
  16617.     /* Initialized data */
  16618.  
  16619.     static doublereal tp = 6.283185308;
  16620.     static doublereal pi8 = 25.13274123;
  16621.     static struct {
  16622.     doublereal e_1[3];
  16623.     } equiv_0 = { 0., 1., 0. };
  16624.  
  16625.     static struct {
  16626.     doublereal e_1[3];
  16627.     } equiv_1 = { 0., -6.283185308, 0. };
  16628.  
  16629.  
  16630.     /* System generated locals */
  16631.     doublereal d__1, d__2, d__3;
  16632.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
  16633.  
  16634.     /* Builtin functions */
  16635.     double cos(), sin(), sqrt();
  16636.     void z_exp();
  16637.  
  16638.     /* Local variables */
  16639.     static doublecomplex cons;
  16640. #define fjkx ((doublereal *)&equiv_1)
  16641.     static doublereal r1, r2;
  16642.     static doublecomplex t1, t2;
  16643.     static doublereal z1, z2, dh, dk;
  16644. #define fj ((doublecomplex *)&equiv_0)
  16645.     static doublereal zp, rh2, cdk;
  16646.     extern /* Subroutine */ int hfk_();
  16647. #define fjk ((doublecomplex *)&equiv_1)
  16648.     static doublereal hki, sdk, hkr;
  16649. #define fjx ((doublereal *)&equiv_0)
  16650.     static doublereal hss, rhz;
  16651.     static doublecomplex ekr1, ekr2;
  16652.  
  16653. /* *** */
  16654. /*     CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT 
  16655. */
  16656. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  16657. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  16658. /*<       COMPLEX  FJ, FJK, EKR1, EKR2, T1, T2, CONS, HPS, HPC, HPK >*/
  16659. /*<       DIMENSION  FJX(2), FJKX(2) >*/
  16660. /*<       EQUIVALENCE(FJ,FJX),(FJK,FJKX) >*/
  16661. /*<       DATA   TP/6.283185308D+0/, FJX/0.,1./, FJKX/0.,-6.283185308D+0/ >*/
  16662. /*<       DATA   PI8/25.13274123D+0/ >*/
  16663. /*<       IF( RH.LT.1.D-10) GOTO 6 >*/
  16664.     if (*rh < 1e-10) {
  16665.     goto L6;
  16666.     }
  16667. /*<       IF( ZPX.LT.0.) GOTO 1 >*/
  16668.     if (*zpx < 0.) {
  16669.     goto L1;
  16670.     }
  16671. /*<       ZP= ZPX >*/
  16672.     zp = *zpx;
  16673. /*<       HSS=1. >*/
  16674.     hss = 1.;
  16675. /*<       GOTO 2 >*/
  16676.     goto L2;
  16677. /*<     1 ZP=- ZPX >*/
  16678. L1:
  16679.     zp = -(*zpx);
  16680. /*<       HSS=-1. >*/
  16681.     hss = -1.;
  16682. /*<     2 DH=.5* S >*/
  16683. L2:
  16684.     dh = *s * .5;
  16685. /*<       Z1= ZP+ DH >*/
  16686.     z1 = zp + dh;
  16687. /*<       Z2= ZP- DH >*/
  16688.     z2 = zp - dh;
  16689. /*<       IF( Z2.LT.1.D-7) GOTO 3 >*/
  16690.     if (z2 < 1e-7) {
  16691.     goto L3;
  16692.     }
  16693. /*<       RHZ= RH/ Z2 >*/
  16694.     rhz = *rh / z2;
  16695. /*<       GOTO 4 >*/
  16696.     goto L4;
  16697. /*<     3 RHZ=1. >*/
  16698. L3:
  16699.     rhz = 1.;
  16700. /*<     4 DK= TP* DH >*/
  16701. L4:
  16702.     dk = tp * dh;
  16703. /*<       CDK= COS( DK) >*/
  16704.     cdk = cos(dk);
  16705. /*<       SDK= SIN( DK) >*/
  16706.     sdk = sin(dk);
  16707. /*<       CALL HFK(- DK, DK, RH* TP, ZP* TP, HKR, HKI) >*/
  16708.     d__1 = -dk;
  16709.     d__2 = *rh * tp;
  16710.     d__3 = zp * tp;
  16711.     hfk_(&d__1, &dk, &d__2, &d__3, &hkr, &hki);
  16712. /*<       HPK= CMPLX( HKR, HKI) >*/
  16713.     z__1.r = hkr, z__1.i = hki;
  16714.     hpk->r = z__1.r, hpk->i = z__1.i;
  16715. /*<       IF( RHZ.LT.1.D-3) GOTO 5 >*/
  16716.     if (rhz < .001) {
  16717.     goto L5;
  16718.     }
  16719. /*<       RH2= RH* RH >*/
  16720.     rh2 = *rh * *rh;
  16721. /*<       R1= SQRT( RH2+ Z1* Z1) >*/
  16722.     r1 = sqrt(rh2 + z1 * z1);
  16723. /*<       R2= SQRT( RH2+ Z2* Z2) >*/
  16724.     r2 = sqrt(rh2 + z2 * z2);
  16725. /*<       EKR1= EXP( FJK* R1) >*/
  16726.     z__2.r = r1 * fjk->r, z__2.i = r1 * fjk->i;
  16727.     z_exp(&z__1, &z__2);
  16728.     ekr1.r = z__1.r, ekr1.i = z__1.i;
  16729. /*<       EKR2= EXP( FJK* R2) >*/
  16730.     z__2.r = r2 * fjk->r, z__2.i = r2 * fjk->i;
  16731.     z_exp(&z__1, &z__2);
  16732.     ekr2.r = z__1.r, ekr2.i = z__1.i;
  16733. /*<       T1= Z1* EKR1/ R1 >*/
  16734.     z__2.r = z1 * ekr1.r, z__2.i = z1 * ekr1.i;
  16735.     z__1.r = z__2.r / r1, z__1.i = z__2.i / r1;
  16736.     t1.r = z__1.r, t1.i = z__1.i;
  16737. /*<       T2= Z2* EKR2/ R2 >*/
  16738.     z__2.r = z2 * ekr2.r, z__2.i = z2 * ekr2.i;
  16739.     z__1.r = z__2.r / r2, z__1.i = z__2.i / r2;
  16740.     t2.r = z__1.r, t2.i = z__1.i;
  16741. /*<       HPS=( CDK*( EKR2- EKR1)- FJ* SDK*( T2+ T1))* HSS >*/
  16742.     z__4.r = ekr2.r - ekr1.r, z__4.i = ekr2.i - ekr1.i;
  16743.     z__3.r = cdk * z__4.r, z__3.i = cdk * z__4.i;
  16744.     z__6.r = sdk * fj->r, z__6.i = sdk * fj->i;
  16745.     z__7.r = t2.r + t1.r, z__7.i = t2.i + t1.i;
  16746.     z__5.r = z__6.r * z__7.r - z__6.i * z__7.i, z__5.i = z__6.r * z__7.i + 
  16747.         z__6.i * z__7.r;
  16748.     z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
  16749.     z__1.r = hss * z__2.r, z__1.i = hss * z__2.i;
  16750.     hps->r = z__1.r, hps->i = z__1.i;
  16751. /*<       HPC=- SDK*( EKR2+ EKR1)- FJ* CDK*( T2- T1) >*/
  16752.     d__1 = -sdk;
  16753.     z__3.r = ekr2.r + ekr1.r, z__3.i = ekr2.i + ekr1.i;
  16754.     z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
  16755.     z__5.r = cdk * fj->r, z__5.i = cdk * fj->i;
  16756.     z__6.r = t2.r - t1.r, z__6.i = t2.i - t1.i;
  16757.     z__4.r = z__5.r * z__6.r - z__5.i * z__6.i, z__4.i = z__5.r * z__6.i + 
  16758.         z__5.i * z__6.r;
  16759.     z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
  16760.     hpc->r = z__1.r, hpc->i = z__1.i;
  16761. /*<       CONS=- FJ/(2.* TP* RH) >*/
  16762.     z__2.r = -fj->r, z__2.i = -fj->i;
  16763.     d__2 = tp * 2.;
  16764.     d__1 = d__2 * *rh;
  16765.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  16766.     cons.r = z__1.r, cons.i = z__1.i;
  16767. /*<       HPS= CONS* HPS >*/
  16768.     z__1.r = cons.r * hps->r - cons.i * hps->i, z__1.i = cons.r * hps->i + 
  16769.         cons.i * hps->r;
  16770.     hps->r = z__1.r, hps->i = z__1.i;
  16771. /*<       HPC= CONS* HPC >*/
  16772.     z__1.r = cons.r * hpc->r - cons.i * hpc->i, z__1.i = cons.r * hpc->i + 
  16773.         cons.i * hpc->r;
  16774.     hpc->r = z__1.r, hpc->i = z__1.i;
  16775. /*<       RETURN >*/
  16776.     return 0;
  16777. /*<     5 EKR1= CMPLX( CDK, SDK)/( Z2* Z2) >*/
  16778. L5:
  16779.     z__2.r = cdk, z__2.i = sdk;
  16780.     d__1 = z2 * z2;
  16781.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  16782.     ekr1.r = z__1.r, ekr1.i = z__1.i;
  16783. /*<       EKR2= CMPLX( CDK,- SDK)/( Z1* Z1) >*/
  16784.     d__1 = -sdk;
  16785.     z__2.r = cdk, z__2.i = d__1;
  16786.     d__2 = z1 * z1;
  16787.     z__1.r = z__2.r / d__2, z__1.i = z__2.i / d__2;
  16788.     ekr2.r = z__1.r, ekr2.i = z__1.i;
  16789. /*<       T1= TP*(1./ Z1-1./ Z2) >*/
  16790.     d__1 = tp * (1. / z1 - 1. / z2);
  16791.     t1.r = d__1, t1.i = 0.;
  16792. /*<       T2= EXP( FJK* ZP)* RH/ PI8 >*/
  16793.     z__4.r = zp * fjk->r, z__4.i = zp * fjk->i;
  16794.     z_exp(&z__3, &z__4);
  16795.     z__2.r = *rh * z__3.r, z__2.i = *rh * z__3.i;
  16796.     z__1.r = z__2.r / pi8, z__1.i = z__2.i / pi8;
  16797.     t2.r = z__1.r, t2.i = z__1.i;
  16798. /*<       HPS= T2*( T1+( EKR1+ EKR2)* SDK)* HSS >*/
  16799.     z__5.r = ekr1.r + ekr2.r, z__5.i = ekr1.i + ekr2.i;
  16800.     z__4.r = sdk * z__5.r, z__4.i = sdk * z__5.i;
  16801.     z__3.r = t1.r + z__4.r, z__3.i = t1.i + z__4.i;
  16802.     z__2.r = t2.r * z__3.r - t2.i * z__3.i, z__2.i = t2.r * z__3.i + t2.i * 
  16803.         z__3.r;
  16804.     z__1.r = hss * z__2.r, z__1.i = hss * z__2.i;
  16805.     hps->r = z__1.r, hps->i = z__1.i;
  16806. /*<       HPC= T2*(- FJ* T1+( EKR1- EKR2)* CDK) >*/
  16807.     z__4.r = -fj->r, z__4.i = -fj->i;
  16808.     z__3.r = z__4.r * t1.r - z__4.i * t1.i, z__3.i = z__4.r * t1.i + z__4.i * 
  16809.         t1.r;
  16810.     z__6.r = ekr1.r - ekr2.r, z__6.i = ekr1.i - ekr2.i;
  16811.     z__5.r = cdk * z__6.r, z__5.i = cdk * z__6.i;
  16812.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  16813.     z__1.r = t2.r * z__2.r - t2.i * z__2.i, z__1.i = t2.r * z__2.i + t2.i * 
  16814.         z__2.r;
  16815.     hpc->r = z__1.r, hpc->i = z__1.i;
  16816. /*<       RETURN >*/
  16817.     return 0;
  16818. /*<     6 HPS=(0.,0.) >*/
  16819. L6:
  16820.     hps->r = 0., hps->i = 0.;
  16821. /*<       HPC=(0.,0.) >*/
  16822.     hpc->r = 0., hpc->i = 0.;
  16823. /*<       HPK=(0.,0.) >*/
  16824.     hpk->r = 0., hpk->i = 0.;
  16825. /*<       RETURN >*/
  16826.     return 0;
  16827. /*<       END >*/
  16828. } /* hsflx_ */
  16829.  
  16830. #undef fjx
  16831. #undef fjk
  16832. #undef fj
  16833. #undef fjkx
  16834.  
  16835.  
  16836. /* *** */
  16837. /*     DOUBLE PRECISION 6/4/85 */
  16838.  
  16839. /*<       SUBROUTINE INTRP( X, Y, F1, F2, F3, F4) >*/
  16840. /* Subroutine */ int intrp_(x, y, f1, f2, f3, f4)
  16841. doublereal *x, *y;
  16842. doublecomplex *f1, *f2, *f3, *f4;
  16843. {
  16844.     /* Initialized data */
  16845.  
  16846.     static integer ixs = -10;
  16847.     static integer iys = -10;
  16848.     static integer igrs = -10;
  16849.     static doublereal dx = 1.;
  16850.     static doublereal dy = 1.;
  16851.     static doublereal xs = 0.;
  16852.     static doublereal ys = 0.;
  16853.     static integer nda[3] = { 11,17,9 };
  16854.     static integer ndpa[3] = { 110,85,72 };
  16855.     static integer ixeg = 0;
  16856.     static integer iyeg = 0;
  16857.  
  16858.     /* System generated locals */
  16859.     integer i__1, i__2;
  16860.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
  16861.     static doublecomplex equiv_15[16], equiv_31[16], equiv_47[16], equiv_63[
  16862.         16];
  16863.  
  16864.     /* Local variables */
  16865.     static integer iadd, iadz, nxms, nyms;
  16866. #define a (equiv_15)
  16867. #define b (equiv_31)
  16868. #define c (equiv_47)
  16869. #define d (equiv_63)
  16870.     static integer i, k;
  16871.     static doublecomplex p1, p2, p3, p4;
  16872. #define a11 (equiv_15)
  16873. #define a12 (equiv_15 + 4)
  16874. #define a13 (equiv_15 + 8)
  16875. #define a14 (equiv_15 + 12)
  16876. #define a21 (equiv_15 + 1)
  16877. #define a22 (equiv_15 + 5)
  16878. #define a23 (equiv_15 + 9)
  16879. #define a24 (equiv_15 + 13)
  16880. #define a31 (equiv_15 + 2)
  16881. #define a32 (equiv_15 + 6)
  16882. #define a33 (equiv_15 + 10)
  16883. #define a34 (equiv_15 + 14)
  16884. #define a41 (equiv_15 + 3)
  16885. #define a42 (equiv_15 + 7)
  16886. #define a43 (equiv_15 + 11)
  16887. #define a44 (equiv_15 + 15)
  16888. #define b11 (equiv_31)
  16889. #define b12 (equiv_31 + 4)
  16890. #define b13 (equiv_31 + 8)
  16891. #define b14 (equiv_31 + 12)
  16892. #define b21 (equiv_31 + 1)
  16893. #define b22 (equiv_31 + 5)
  16894. #define b23 (equiv_31 + 9)
  16895. #define b24 (equiv_31 + 13)
  16896. #define b31 (equiv_31 + 2)
  16897. #define b32 (equiv_31 + 6)
  16898. #define b33 (equiv_31 + 10)
  16899. #define b34 (equiv_31 + 14)
  16900. #define b41 (equiv_31 + 3)
  16901. #define b42 (equiv_31 + 7)
  16902. #define b43 (equiv_31 + 11)
  16903. #define b44 (equiv_31 + 15)
  16904. #define c11 (equiv_47)
  16905. #define c12 (equiv_47 + 4)
  16906. #define c13 (equiv_47 + 8)
  16907. #define c14 (equiv_47 + 12)
  16908. #define c21 (equiv_47 + 1)
  16909. #define c22 (equiv_47 + 5)
  16910. #define c23 (equiv_47 + 9)
  16911. #define c24 (equiv_47 + 13)
  16912. #define c31 (equiv_47 + 2)
  16913. #define c32 (equiv_47 + 6)
  16914. #define c33 (equiv_47 + 10)
  16915. #define c34 (equiv_47 + 14)
  16916. #define c41 (equiv_47 + 3)
  16917. #define c42 (equiv_47 + 7)
  16918. #define c43 (equiv_47 + 11)
  16919. #define c44 (equiv_47 + 15)
  16920. #define d11 (equiv_63)
  16921. #define d12 (equiv_63 + 4)
  16922. #define d13 (equiv_63 + 8)
  16923. #define d14 (equiv_63 + 12)
  16924. #define d21 (equiv_63 + 1)
  16925. #define d22 (equiv_63 + 5)
  16926. #define d23 (equiv_63 + 9)
  16927. #define d24 (equiv_63 + 13)
  16928. #define d31 (equiv_63 + 2)
  16929. #define d32 (equiv_63 + 6)
  16930. #define d33 (equiv_63 + 10)
  16931. #define d34 (equiv_63 + 14)
  16932. #define d41 (equiv_63 + 3)
  16933. #define d42 (equiv_63 + 7)
  16934. #define d43 (equiv_63 + 11)
  16935. #define d44 (equiv_63 + 15)
  16936.     static integer ix, iy;
  16937.     static doublecomplex fx1, fx2, fx3, fx4;
  16938.     static integer nd;
  16939.     static doublereal xz, yz, xx, yy;
  16940. #define xs2 ((doublereal *)&ggrid_1 + 2145)
  16941. #define ys3 ((doublereal *)&ggrid_1 + 2149)
  16942.     static integer igr, ndp;
  16943. #define arl1 ((doublecomplex *)&ggrid_1)
  16944. #define arl2 ((doublecomplex *)&ggrid_1 + 440)
  16945. #define arl3 ((doublecomplex *)&ggrid_1 + 780)
  16946.     static integer nxm2, nym2;
  16947.  
  16948. /* *** */
  16949.  
  16950. /*     INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OF */
  16951.  
  16952. /*     4 FUNCTIONS AT THE POINT (X,Y). */
  16953.  
  16954. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  16955. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  16956. /*<    >*/
  16957. /*<       COMPLEX  AR1, AR2, AR3, ARL1, ARL2, ARL3, EPSCF >*/
  16958. /*<    >*/
  16959. /*<       DIMENSION  NDA(3), NDPA(3) >*/
  16960. /*<    >*/
  16961. /*<       EQUIVALENCE(A(1,1),A11),(A(1,2),A12),(A(1,3),A13),(A(1,4),A14) >*/
  16962. /*<       EQUIVALENCE(A(2,1),A21),(A(2,2),A22),(A(2,3),A23),(A(2,4),A24) >*/
  16963. /*<       EQUIVALENCE(A(3,1),A31),(A(3,2),A32),(A(3,3),A33),(A(3,4),A34) >*/
  16964. /*<       EQUIVALENCE(A(4,1),A41),(A(4,2),A42),(A(4,3),A43),(A(4,4),A44) >*/
  16965. /*<       EQUIVALENCE(B(1,1),B11),(B(1,2),B12),(B(1,3),B13),(B(1,4),B14) >*/
  16966. /*<       EQUIVALENCE(B(2,1),B21),(B(2,2),B22),(B(2,3),B23),(B(2,4),B24) >*/
  16967. /*<       EQUIVALENCE(B(3,1),B31),(B(3,2),B32),(B(3,3),B33),(B(3,4),B34) >*/
  16968. /*<       EQUIVALENCE(B(4,1),B41),(B(4,2),B42),(B(4,3),B43),(B(4,4),B44) >*/
  16969. /*<       EQUIVALENCE(C(1,1),C11),(C(1,2),C12),(C(1,3),C13),(C(1,4),C14) >*/
  16970. /*<       EQUIVALENCE(C(2,1),C21),(C(2,2),C22),(C(2,3),C23),(C(2,4),C24) >*/
  16971. /*<       EQUIVALENCE(C(3,1),C31),(C(3,2),C32),(C(3,3),C33),(C(3,4),C34) >*/
  16972. /*<       EQUIVALENCE(C(4,1),C41),(C(4,2),C42),(C(4,3),C43),(C(4,4),C44) >*/
  16973. /*<       EQUIVALENCE(D(1,1),D11),(D(1,2),D12),(D(1,3),D13),(D(1,4),D14) >*/
  16974. /*<       EQUIVALENCE(D(2,1),D21),(D(2,2),D22),(D(2,3),D23),(D(2,4),D24) >*/
  16975. /*<       EQUIVALENCE(D(3,1),D31),(D(3,2),D32),(D(3,3),D33),(D(3,4),D34) >*/
  16976. /*<       EQUIVALENCE(D(4,1),D41),(D(4,2),D42),(D(4,3),D43),(D(4,4),D44) >*/
  16977. /*<    >*/
  16978. /*<       DATA   IXS, IYS, IGRS/-10,-10,-10/, DX, DY, XS, YS/1.,1.,0.,0./ >*/
  16979. /*<       DATA   NDA/11,17,9/, NDPA/110,85,72/, IXEG, IYEG/0,0/ >*/
  16980. /*<       IF( X.LT. XS.OR. Y.LT. YS) GOTO 1 >*/
  16981.     if (*x < xs || *y < ys) {
  16982.     goto L1;
  16983.     }
  16984. /*<       IX= INT(( X- XS)/ DX)+1 >*/
  16985.     ix = (integer) ((*x - xs) / dx) + 1;
  16986.  
  16987. /*     IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLD */
  16988.  
  16989. /*     VALUES ARE REUSED */
  16990.  
  16991. /*<       IY= INT(( Y- YS)/ DY)+1 >*/
  16992.     iy = (integer) ((*y - ys) / dy) + 1;
  16993. /*<       IF( IX.LT. IXEG.OR. IY.LT. IYEG) GOTO 1 >*/
  16994.     if (ix < ixeg || iy < iyeg) {
  16995.     goto L1;
  16996.     }
  16997.  
  16998. /*     DETERMINE CORRECT GRID AND GRID REGION */
  16999.  
  17000. /*<       IF( IABS( IX- IXS).LT.2.AND. IABS( IY- IYS).LT.2) GOTO 12 >*/
  17001.     if ((i__1 = ix - ixs, abs(i__1)) < 2 && (i__2 = iy - iys, abs(i__2)) < 2) 
  17002.         {
  17003.     goto L12;
  17004.     }
  17005. /*<     1 IF( X.GT. XS2) GOTO 2 >*/
  17006. L1:
  17007.     if (*x > *xs2) {
  17008.     goto L2;
  17009.     }
  17010. /*<       IGR=1 >*/
  17011.     igr = 1;
  17012. /*<       GOTO 3 >*/
  17013.     goto L3;
  17014. /*<     2 IGR=2 >*/
  17015. L2:
  17016.     igr = 2;
  17017. /*<       IF( Y.GT. YS3) IGR=3 >*/
  17018.     if (*y > *ys3) {
  17019.     igr = 3;
  17020.     }
  17021. /*<     3 IF( IGR.EQ. IGRS) GOTO 4 >*/
  17022. L3:
  17023.     if (igr == igrs) {
  17024.     goto L4;
  17025.     }
  17026. /*<       IGRS= IGR >*/
  17027.     igrs = igr;
  17028. /*<       DX= DXA( IGRS) >*/
  17029.     dx = ggrid_1.dxa[igrs - 1];
  17030. /*<       DY= DYA( IGRS) >*/
  17031.     dy = ggrid_1.dya[igrs - 1];
  17032. /*<       XS= XSA( IGRS) >*/
  17033.     xs = ggrid_1.xsa[igrs - 1];
  17034. /*<       YS= YSA( IGRS) >*/
  17035.     ys = ggrid_1.ysa[igrs - 1];
  17036. /*<       NXM2= NXA( IGRS)-2 >*/
  17037.     nxm2 = ggrid_1.nxa[igrs - 1] - 2;
  17038. /*<       NYM2= NYA( IGRS)-2 >*/
  17039.     nym2 = ggrid_1.nya[igrs - 1] - 2;
  17040. /*<       NXMS=(( NXM2+1)/3)*3+1 >*/
  17041.     nxms = (nxm2 + 1) / 3 * 3 + 1;
  17042. /*<       NYMS=(( NYM2+1)/3)*3+1 >*/
  17043.     nyms = (nym2 + 1) / 3 * 3 + 1;
  17044. /*<       ND= NDA( IGRS) >*/
  17045.     nd = nda[igrs - 1];
  17046. /*<       NDP= NDPA( IGRS) >*/
  17047.     ndp = ndpa[igrs - 1];
  17048. /*<       IX= INT(( X- XS)/ DX)+1 >*/
  17049.     ix = (integer) ((*x - xs) / dx) + 1;
  17050. /*<       IY= INT(( Y- YS)/ DY)+1 >*/
  17051.     iy = (integer) ((*y - ys) / dy) + 1;
  17052. /*<     4 IXS=(( IX-1)/3)*3+2 >*/
  17053. L4:
  17054.     ixs = (ix - 1) / 3 * 3 + 2;
  17055. /*<       IF( IXS.LT.2) IXS=2 >*/
  17056.     if (ixs < 2) {
  17057.     ixs = 2;
  17058.     }
  17059. /*<       IXEG=-10000 >*/
  17060.     ixeg = -10000;
  17061. /*<       IF( IXS.LE. NXM2) GOTO 5 >*/
  17062.     if (ixs <= nxm2) {
  17063.     goto L5;
  17064.     }
  17065. /*<       IXS= NXM2 >*/
  17066.     ixs = nxm2;
  17067. /*<       IXEG= NXMS >*/
  17068.     ixeg = nxms;
  17069. /*<     5 IYS=(( IY-1)/3)*3+2 >*/
  17070. L5:
  17071.     iys = (iy - 1) / 3 * 3 + 2;
  17072. /*<       IF( IYS.LT.2) IYS=2 >*/
  17073.     if (iys < 2) {
  17074.     iys = 2;
  17075.     }
  17076. /*<       IYEG=-10000 >*/
  17077.     iyeg = -10000;
  17078. /*<       IF( IYS.LE. NYM2) GOTO 6 >*/
  17079.     if (iys <= nym2) {
  17080.     goto L6;
  17081.     }
  17082. /*<       IYS= NYM2 >*/
  17083.     iys = nym2;
  17084.  
  17085. /*     COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRID */
  17086. /*     VALUES OF Y FOR EACH OF THE 4 FUNCTIONS */
  17087.  
  17088. /*<       IYEG= NYMS >*/
  17089.     iyeg = nyms;
  17090. /*<     6 IADZ= IXS+( IYS-3)* ND- NDP >*/
  17091. L6:
  17092.     iadz = ixs + (iys - 3) * nd - ndp;
  17093. /*<       DO 11  K=1,4 >*/
  17094.     for (k = 1; k <= 4; ++k) {
  17095. /*<       IADZ= IADZ+ NDP >*/
  17096.     iadz += ndp;
  17097. /*<       IADD= IADZ >*/
  17098.     iadd = iadz;
  17099. /*<       DO 11  I=1,4 >*/
  17100.     for (i = 1; i <= 4; ++i) {
  17101. /*<       IADD= IADD+ ND >*/
  17102.         iadd += nd;
  17103. /*     P1=AR1(IXS-1,IYS-2+I,K) */
  17104. /*<       GOTO (7,8,9), IGRS >*/
  17105.         switch ((int)(igrs)) {
  17106.         case 1:  goto L7;
  17107.         case 2:  goto L8;
  17108.         case 3:  goto L9;
  17109.         }
  17110. /*<     7 P1= ARL1( IADD-1) >*/
  17111. L7:
  17112.         i__1 = iadd - 2;
  17113.         p1.r = arl1[i__1].r, p1.i = arl1[i__1].i;
  17114. /*<       P2= ARL1( IADD) >*/
  17115.         i__1 = iadd - 1;
  17116.         p2.r = arl1[i__1].r, p2.i = arl1[i__1].i;
  17117. /*<       P3= ARL1( IADD+1) >*/
  17118.         i__1 = iadd;
  17119.         p3.r = arl1[i__1].r, p3.i = arl1[i__1].i;
  17120. /*<       P4= ARL1( IADD+2) >*/
  17121.         i__1 = iadd + 1;
  17122.         p4.r = arl1[i__1].r, p4.i = arl1[i__1].i;
  17123. /*<       GOTO 10 >*/
  17124.         goto L10;
  17125. /*<     8 P1= ARL2( IADD-1) >*/
  17126. L8:
  17127.         i__1 = iadd - 2;
  17128.         p1.r = arl2[i__1].r, p1.i = arl2[i__1].i;
  17129. /*<       P2= ARL2( IADD) >*/
  17130.         i__1 = iadd - 1;
  17131.         p2.r = arl2[i__1].r, p2.i = arl2[i__1].i;
  17132. /*<       P3= ARL2( IADD+1) >*/
  17133.         i__1 = iadd;
  17134.         p3.r = arl2[i__1].r, p3.i = arl2[i__1].i;
  17135. /*<       P4= ARL2( IADD+2) >*/
  17136.         i__1 = iadd + 1;
  17137.         p4.r = arl2[i__1].r, p4.i = arl2[i__1].i;
  17138. /*<       GOTO 10 >*/
  17139.         goto L10;
  17140. /*<     9 P1= ARL3( IADD-1) >*/
  17141. L9:
  17142.         i__1 = iadd - 2;
  17143.         p1.r = arl3[i__1].r, p1.i = arl3[i__1].i;
  17144. /*<       P2= ARL3( IADD) >*/
  17145.         i__1 = iadd - 1;
  17146.         p2.r = arl3[i__1].r, p2.i = arl3[i__1].i;
  17147. /*<       P3= ARL3( IADD+1) >*/
  17148.         i__1 = iadd;
  17149.         p3.r = arl3[i__1].r, p3.i = arl3[i__1].i;
  17150. /*<       P4= ARL3( IADD+2) >*/
  17151.         i__1 = iadd + 1;
  17152.         p4.r = arl3[i__1].r, p4.i = arl3[i__1].i;
  17153. /*<    10 A( I, K)=( P4- P1+3.*( P2- P3))*.1666666667D+0 >*/
  17154. L10:
  17155.         i__1 = i + (k << 2) - 5;
  17156.         z__3.r = p4.r - p1.r, z__3.i = p4.i - p1.i;
  17157.         z__5.r = p2.r - p3.r, z__5.i = p2.i - p3.i;
  17158.         z__4.r = z__5.r * 3., z__4.i = z__5.i * 3.;
  17159.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  17160.         z__1.r = z__2.r * .1666666667, z__1.i = z__2.i * .1666666667;
  17161.         a[i__1].r = z__1.r, a[i__1].i = z__1.i;
  17162. /*<       B( I, K)=( P1-2.* P2+ P3)*.5 >*/
  17163.         i__1 = i + (k << 2) - 5;
  17164.         z__4.r = p2.r * 2., z__4.i = p2.i * 2.;
  17165.         z__3.r = p1.r - z__4.r, z__3.i = p1.i - z__4.i;
  17166.         z__2.r = z__3.r + p3.r, z__2.i = z__3.i + p3.i;
  17167.         z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
  17168.         b[i__1].r = z__1.r, b[i__1].i = z__1.i;
  17169. /*<       C( I, K)= P3-(2.* P1+3.* P2+ P4)*.1666666667D+0 >*/
  17170.         i__1 = i + (k << 2) - 5;
  17171.         z__5.r = p1.r * 2., z__5.i = p1.i * 2.;
  17172.         z__6.r = p2.r * 3., z__6.i = p2.i * 3.;
  17173.         z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  17174.         z__3.r = z__4.r + p4.r, z__3.i = z__4.i + p4.i;
  17175.         z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
  17176.         z__1.r = p3.r - z__2.r, z__1.i = p3.i - z__2.i;
  17177.         c[i__1].r = z__1.r, c[i__1].i = z__1.i;
  17178. /*<    11 D( I, K)= P2 >*/
  17179. /* L11: */
  17180.         i__1 = i + (k << 2) - 5;
  17181.         d[i__1].r = p2.r, d[i__1].i = p2.i;
  17182.     }
  17183.     }
  17184. /*<       XZ=( IXS-1)* DX+ XS >*/
  17185.     xz = (ixs - 1) * dx + xs;
  17186.  
  17187. /*     EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN Y */
  17188. /*     FOR EACH OF THE 4 FUNCTIONS. */
  17189.  
  17190. /*<       YZ=( IYS-1)* DY+ YS >*/
  17191.     yz = (iys - 1) * dy + ys;
  17192. /*<    12 XX=( X- XZ)/ DX >*/
  17193. L12:
  17194.     xx = (*x - xz) / dx;
  17195. /*<       YY=( Y- YZ)/ DY >*/
  17196.     yy = (*y - yz) / dy;
  17197. /*<       FX1=(( A11* XX+ B11)* XX+ C11)* XX+ D11 >*/
  17198.     z__6.r = xx * a11->r, z__6.i = xx * a11->i;
  17199.     z__5.r = z__6.r + b11->r, z__5.i = z__6.i + b11->i;
  17200.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17201.     z__3.r = z__4.r + c11->r, z__3.i = z__4.i + c11->i;
  17202.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17203.     z__1.r = z__2.r + d11->r, z__1.i = z__2.i + d11->i;
  17204.     fx1.r = z__1.r, fx1.i = z__1.i;
  17205. /*<       FX2=(( A21* XX+ B21)* XX+ C21)* XX+ D21 >*/
  17206.     z__6.r = xx * a21->r, z__6.i = xx * a21->i;
  17207.     z__5.r = z__6.r + b21->r, z__5.i = z__6.i + b21->i;
  17208.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17209.     z__3.r = z__4.r + c21->r, z__3.i = z__4.i + c21->i;
  17210.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17211.     z__1.r = z__2.r + d21->r, z__1.i = z__2.i + d21->i;
  17212.     fx2.r = z__1.r, fx2.i = z__1.i;
  17213. /*<       FX3=(( A31* XX+ B31)* XX+ C31)* XX+ D31 >*/
  17214.     z__6.r = xx * a31->r, z__6.i = xx * a31->i;
  17215.     z__5.r = z__6.r + b31->r, z__5.i = z__6.i + b31->i;
  17216.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17217.     z__3.r = z__4.r + c31->r, z__3.i = z__4.i + c31->i;
  17218.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17219.     z__1.r = z__2.r + d31->r, z__1.i = z__2.i + d31->i;
  17220.     fx3.r = z__1.r, fx3.i = z__1.i;
  17221. /*<       FX4=(( A41* XX+ B41)* XX+ C41)* XX+ D41 >*/
  17222.     z__6.r = xx * a41->r, z__6.i = xx * a41->i;
  17223.     z__5.r = z__6.r + b41->r, z__5.i = z__6.i + b41->i;
  17224.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17225.     z__3.r = z__4.r + c41->r, z__3.i = z__4.i + c41->i;
  17226.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17227.     z__1.r = z__2.r + d41->r, z__1.i = z__2.i + d41->i;
  17228.     fx4.r = z__1.r, fx4.i = z__1.i;
  17229. /*<       P1= FX4- FX1+3.*( FX2- FX3) >*/
  17230.     z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
  17231.     z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
  17232.     z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
  17233.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  17234.     p1.r = z__1.r, p1.i = z__1.i;
  17235. /*<       P2=3.*( FX1-2.* FX2+ FX3) >*/
  17236.     z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
  17237.     z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
  17238.     z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
  17239.     z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
  17240.     p2.r = z__1.r, p2.i = z__1.i;
  17241. /*<       P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
  17242.     z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
  17243.     z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
  17244.     z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
  17245.     z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
  17246.     z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
  17247.     z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
  17248.     p3.r = z__1.r, p3.i = z__1.i;
  17249. /*<       F1=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
  17250.     z__7.r = yy * p1.r, z__7.i = yy * p1.i;
  17251.     z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
  17252.     z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
  17253.     z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
  17254.     z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
  17255.     z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
  17256.     z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
  17257.     f1->r = z__1.r, f1->i = z__1.i;
  17258. /*<       FX1=(( A12* XX+ B12)* XX+ C12)* XX+ D12 >*/
  17259.     z__6.r = xx * a12->r, z__6.i = xx * a12->i;
  17260.     z__5.r = z__6.r + b12->r, z__5.i = z__6.i + b12->i;
  17261.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17262.     z__3.r = z__4.r + c12->r, z__3.i = z__4.i + c12->i;
  17263.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17264.     z__1.r = z__2.r + d12->r, z__1.i = z__2.i + d12->i;
  17265.     fx1.r = z__1.r, fx1.i = z__1.i;
  17266. /*<       FX2=(( A22* XX+ B22)* XX+ C22)* XX+ D22 >*/
  17267.     z__6.r = xx * a22->r, z__6.i = xx * a22->i;
  17268.     z__5.r = z__6.r + b22->r, z__5.i = z__6.i + b22->i;
  17269.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17270.     z__3.r = z__4.r + c22->r, z__3.i = z__4.i + c22->i;
  17271.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17272.     z__1.r = z__2.r + d22->r, z__1.i = z__2.i + d22->i;
  17273.     fx2.r = z__1.r, fx2.i = z__1.i;
  17274. /*<       FX3=(( A32* XX+ B32)* XX+ C32)* XX+ D32 >*/
  17275.     z__6.r = xx * a32->r, z__6.i = xx * a32->i;
  17276.     z__5.r = z__6.r + b32->r, z__5.i = z__6.i + b32->i;
  17277.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17278.     z__3.r = z__4.r + c32->r, z__3.i = z__4.i + c32->i;
  17279.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17280.     z__1.r = z__2.r + d32->r, z__1.i = z__2.i + d32->i;
  17281.     fx3.r = z__1.r, fx3.i = z__1.i;
  17282. /*<       FX4=(( A42* XX+ B42)* XX+ C42)* XX+ D42 >*/
  17283.     z__6.r = xx * a42->r, z__6.i = xx * a42->i;
  17284.     z__5.r = z__6.r + b42->r, z__5.i = z__6.i + b42->i;
  17285.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17286.     z__3.r = z__4.r + c42->r, z__3.i = z__4.i + c42->i;
  17287.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17288.     z__1.r = z__2.r + d42->r, z__1.i = z__2.i + d42->i;
  17289.     fx4.r = z__1.r, fx4.i = z__1.i;
  17290. /*<       P1= FX4- FX1+3.*( FX2- FX3) >*/
  17291.     z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
  17292.     z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
  17293.     z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
  17294.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  17295.     p1.r = z__1.r, p1.i = z__1.i;
  17296. /*<       P2=3.*( FX1-2.* FX2+ FX3) >*/
  17297.     z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
  17298.     z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
  17299.     z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
  17300.     z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
  17301.     p2.r = z__1.r, p2.i = z__1.i;
  17302. /*<       P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
  17303.     z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
  17304.     z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
  17305.     z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
  17306.     z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
  17307.     z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
  17308.     z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
  17309.     p3.r = z__1.r, p3.i = z__1.i;
  17310. /*<       F2=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
  17311.     z__7.r = yy * p1.r, z__7.i = yy * p1.i;
  17312.     z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
  17313.     z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
  17314.     z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
  17315.     z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
  17316.     z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
  17317.     z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
  17318.     f2->r = z__1.r, f2->i = z__1.i;
  17319. /*<       FX1=(( A13* XX+ B13)* XX+ C13)* XX+ D13 >*/
  17320.     z__6.r = xx * a13->r, z__6.i = xx * a13->i;
  17321.     z__5.r = z__6.r + b13->r, z__5.i = z__6.i + b13->i;
  17322.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17323.     z__3.r = z__4.r + c13->r, z__3.i = z__4.i + c13->i;
  17324.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17325.     z__1.r = z__2.r + d13->r, z__1.i = z__2.i + d13->i;
  17326.     fx1.r = z__1.r, fx1.i = z__1.i;
  17327. /*<       FX2=(( A23* XX+ B23)* XX+ C23)* XX+ D23 >*/
  17328.     z__6.r = xx * a23->r, z__6.i = xx * a23->i;
  17329.     z__5.r = z__6.r + b23->r, z__5.i = z__6.i + b23->i;
  17330.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17331.     z__3.r = z__4.r + c23->r, z__3.i = z__4.i + c23->i;
  17332.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17333.     z__1.r = z__2.r + d23->r, z__1.i = z__2.i + d23->i;
  17334.     fx2.r = z__1.r, fx2.i = z__1.i;
  17335. /*<       FX3=(( A33* XX+ B33)* XX+ C33)* XX+ D33 >*/
  17336.     z__6.r = xx * a33->r, z__6.i = xx * a33->i;
  17337.     z__5.r = z__6.r + b33->r, z__5.i = z__6.i + b33->i;
  17338.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17339.     z__3.r = z__4.r + c33->r, z__3.i = z__4.i + c33->i;
  17340.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17341.     z__1.r = z__2.r + d33->r, z__1.i = z__2.i + d33->i;
  17342.     fx3.r = z__1.r, fx3.i = z__1.i;
  17343. /*<       FX4=(( A43* XX+ B43)* XX+ C43)* XX+ D43 >*/
  17344.     z__6.r = xx * a43->r, z__6.i = xx * a43->i;
  17345.     z__5.r = z__6.r + b43->r, z__5.i = z__6.i + b43->i;
  17346.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17347.     z__3.r = z__4.r + c43->r, z__3.i = z__4.i + c43->i;
  17348.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17349.     z__1.r = z__2.r + d43->r, z__1.i = z__2.i + d43->i;
  17350.     fx4.r = z__1.r, fx4.i = z__1.i;
  17351. /*<       P1= FX4- FX1+3.*( FX2- FX3) >*/
  17352.     z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
  17353.     z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
  17354.     z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
  17355.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  17356.     p1.r = z__1.r, p1.i = z__1.i;
  17357. /*<       P2=3.*( FX1-2.* FX2+ FX3) >*/
  17358.     z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
  17359.     z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
  17360.     z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
  17361.     z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
  17362.     p2.r = z__1.r, p2.i = z__1.i;
  17363. /*<       P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
  17364.     z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
  17365.     z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
  17366.     z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
  17367.     z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
  17368.     z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
  17369.     z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
  17370.     p3.r = z__1.r, p3.i = z__1.i;
  17371. /*<       F3=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
  17372.     z__7.r = yy * p1.r, z__7.i = yy * p1.i;
  17373.     z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
  17374.     z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
  17375.     z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
  17376.     z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
  17377.     z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
  17378.     z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
  17379.     f3->r = z__1.r, f3->i = z__1.i;
  17380. /*<       FX1=(( A14* XX+ B14)* XX+ C14)* XX+ D14 >*/
  17381.     z__6.r = xx * a14->r, z__6.i = xx * a14->i;
  17382.     z__5.r = z__6.r + b14->r, z__5.i = z__6.i + b14->i;
  17383.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17384.     z__3.r = z__4.r + c14->r, z__3.i = z__4.i + c14->i;
  17385.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17386.     z__1.r = z__2.r + d14->r, z__1.i = z__2.i + d14->i;
  17387.     fx1.r = z__1.r, fx1.i = z__1.i;
  17388. /*<       FX2=(( A24* XX+ B24)* XX+ C24)* XX+ D24 >*/
  17389.     z__6.r = xx * a24->r, z__6.i = xx * a24->i;
  17390.     z__5.r = z__6.r + b24->r, z__5.i = z__6.i + b24->i;
  17391.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17392.     z__3.r = z__4.r + c24->r, z__3.i = z__4.i + c24->i;
  17393.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17394.     z__1.r = z__2.r + d24->r, z__1.i = z__2.i + d24->i;
  17395.     fx2.r = z__1.r, fx2.i = z__1.i;
  17396. /*<       FX3=(( A34* XX+ B34)* XX+ C34)* XX+ D34 >*/
  17397.     z__6.r = xx * a34->r, z__6.i = xx * a34->i;
  17398.     z__5.r = z__6.r + b34->r, z__5.i = z__6.i + b34->i;
  17399.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17400.     z__3.r = z__4.r + c34->r, z__3.i = z__4.i + c34->i;
  17401.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17402.     z__1.r = z__2.r + d34->r, z__1.i = z__2.i + d34->i;
  17403.     fx3.r = z__1.r, fx3.i = z__1.i;
  17404. /*<       FX4=(( A44* XX+ B44)* XX+ C44)* XX+ D44 >*/
  17405.     z__6.r = xx * a44->r, z__6.i = xx * a44->i;
  17406.     z__5.r = z__6.r + b44->r, z__5.i = z__6.i + b44->i;
  17407.     z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
  17408.     z__3.r = z__4.r + c44->r, z__3.i = z__4.i + c44->i;
  17409.     z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
  17410.     z__1.r = z__2.r + d44->r, z__1.i = z__2.i + d44->i;
  17411.     fx4.r = z__1.r, fx4.i = z__1.i;
  17412. /*<       P1= FX4- FX1+3.*( FX2- FX3) >*/
  17413.     z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
  17414.     z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
  17415.     z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
  17416.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  17417.     p1.r = z__1.r, p1.i = z__1.i;
  17418. /*<       P2=3.*( FX1-2.* FX2+ FX3) >*/
  17419.     z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
  17420.     z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
  17421.     z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
  17422.     z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
  17423.     p2.r = z__1.r, p2.i = z__1.i;
  17424. /*<       P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
  17425.     z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
  17426.     z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
  17427.     z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
  17428.     z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
  17429.     z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
  17430.     z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
  17431.     p3.r = z__1.r, p3.i = z__1.i;
  17432. /*<       F4=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
  17433.     z__7.r = yy * p1.r, z__7.i = yy * p1.i;
  17434.     z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
  17435.     z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
  17436.     z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
  17437.     z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
  17438.     z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
  17439.     z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
  17440.     f4->r = z__1.r, f4->i = z__1.i;
  17441. /*<       RETURN >*/
  17442.     return 0;
  17443. /*<       END >*/
  17444. } /* intrp_ */
  17445.  
  17446. #undef arl3
  17447. #undef arl2
  17448. #undef arl1
  17449. #undef ys3
  17450. #undef xs2
  17451. #undef d44
  17452. #undef d43
  17453. #undef d42
  17454. #undef d41
  17455. #undef d34
  17456. #undef d33
  17457. #undef d32
  17458. #undef d31
  17459. #undef d24
  17460. #undef d23
  17461. #undef d22
  17462. #undef d21
  17463. #undef d14
  17464. #undef d13
  17465. #undef d12
  17466. #undef d11
  17467. #undef c44
  17468. #undef c43
  17469. #undef c42
  17470. #undef c41
  17471. #undef c34
  17472. #undef c33
  17473. #undef c32
  17474. #undef c31
  17475. #undef c24
  17476. #undef c23
  17477. #undef c22
  17478. #undef c21
  17479. #undef c14
  17480. #undef c13
  17481. #undef c12
  17482. #undef c11
  17483. #undef b44
  17484. #undef b43
  17485. #undef b42
  17486. #undef b41
  17487. #undef b34
  17488. #undef b33
  17489. #undef b32
  17490. #undef b31
  17491. #undef b24
  17492. #undef b23
  17493. #undef b22
  17494. #undef b21
  17495. #undef b14
  17496. #undef b13
  17497. #undef b12
  17498. #undef b11
  17499. #undef a44
  17500. #undef a43
  17501. #undef a42
  17502. #undef a41
  17503. #undef a34
  17504. #undef a33
  17505. #undef a32
  17506. #undef a31
  17507. #undef a24
  17508. #undef a23
  17509. #undef a22
  17510. #undef a21
  17511. #undef a14
  17512. #undef a13
  17513. #undef a12
  17514. #undef a11
  17515. #undef d
  17516. #undef c
  17517. #undef b
  17518. #undef a
  17519.  
  17520.  
  17521. /* *** */
  17522. /*     DOUBLE PRECISION 6/4/85 */
  17523.  
  17524. /*<       SUBROUTINE INTX( EL1, EL2, B, IJ, SGR, SGI) >*/
  17525. /* Subroutine */ int intx_(el1, el2, b, ij, sgr, sgi)
  17526. doublereal *el1, *el2, *b;
  17527. integer *ij;
  17528. doublereal *sgr, *sgi;
  17529. {
  17530.     /* Initialized data */
  17531.  
  17532.     static integer nx = 1;
  17533.     static integer nm = 65536;
  17534.     static integer nts = 4;
  17535.     static doublereal rx = 1e-4;
  17536.  
  17537.     /* Format strings */
  17538.     static char fmt_20[] = "(\002 STEP SIZE LIMITED AT Z=\002,f10.5)";
  17539.  
  17540.     /* Builtin functions */
  17541.     integer s_wsfe(), do_fio(), e_wsfe();
  17542.     double sqrt(), log();
  17543.  
  17544.     /* Local variables */
  17545.     static doublereal zend;
  17546.     extern /* Subroutine */ int test_();
  17547.     static doublereal dzot, s, z;
  17548.     extern /* Subroutine */ int gf_();
  17549.     static doublereal ep, dz, ze;
  17550.     static integer ns, nt;
  17551.     static doublereal zp, g1i, g3i, g5i, g2i, g4i, g1r, g2r, g3r, g4r, g5r, 
  17552.         t00i, t01i, t10i, t02i, fnm, t11i, t20i, t00r, fns, t01r, t10r, 
  17553.         t02r, t11r, t20r, te1i, te2i, te1r, te2r;
  17554.  
  17555.     /* Fortran I/O blocks */
  17556.     static cilist io___1400 = { 0, 6, 0, fmt_20, 0 };
  17557.  
  17558.  
  17559. /* *** */
  17560.  
  17561. /*     INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF 
  17562. */
  17563. /*     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION.  THE INTEGRAND VALUE 
  17564. */
  17565. /*     IS SUPPLIED BY SUBROUTINE GF. */
  17566.  
  17567. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  17568. /*<       DATA   NX, NM, NTS, RX/1,65536,4,1.D-4/ >*/
  17569. /*<       Z= EL1 >*/
  17570.     z = *el1;
  17571. /*<       ZE= EL2 >*/
  17572.     ze = *el2;
  17573. /*<       IF( IJ.EQ.0) ZE=0. >*/
  17574.     if (*ij == 0) {
  17575.     ze = 0.;
  17576.     }
  17577. /*<       S= ZE- Z >*/
  17578.     s = ze - z;
  17579. /*<       FNM= NM >*/
  17580.     fnm = (doublereal) nm;
  17581. /*<       EP= S/(10.* FNM) >*/
  17582.     ep = s / (fnm * 10.);
  17583. /*<       ZEND= ZE- EP >*/
  17584.     zend = ze - ep;
  17585. /*<       SGR=0. >*/
  17586.     *sgr = 0.;
  17587. /*<       SGI=0. >*/
  17588.     *sgi = 0.;
  17589. /*<       NS= NX >*/
  17590.     ns = nx;
  17591. /*<       NT=0 >*/
  17592.     nt = 0;
  17593. /*<       CALL GF( Z, G1R, G1I) >*/
  17594.     gf_(&z, &g1r, &g1i);
  17595. /*<     1 FNS= NS >*/
  17596. L1:
  17597.     fns = (doublereal) ns;
  17598. /*<       DZ= S/ FNS >*/
  17599.     dz = s / fns;
  17600. /*<       ZP= Z+ DZ >*/
  17601.     zp = z + dz;
  17602. /*<       IF( ZP- ZE) 3,3,2 >*/
  17603.     if (zp - ze <= 0.) {
  17604.     goto L3;
  17605.     } else {
  17606.     goto L2;
  17607.     }
  17608. /*<     2 DZ= ZE- Z >*/
  17609. L2:
  17610.     dz = ze - z;
  17611. /*<       IF( ABS( DZ)- EP) 17,17,3 >*/
  17612.     if (abs(dz) - ep <= 0.) {
  17613.     goto L17;
  17614.     } else {
  17615.     goto L3;
  17616.     }
  17617. /*<     3 DZOT= DZ*.5 >*/
  17618. L3:
  17619.     dzot = dz * .5;
  17620. /*<       ZP= Z+ DZOT >*/
  17621.     zp = z + dzot;
  17622. /*<       CALL GF( ZP, G3R, G3I) >*/
  17623.     gf_(&zp, &g3r, &g3i);
  17624. /*<       ZP= Z+ DZ >*/
  17625.     zp = z + dz;
  17626. /*<       CALL GF( ZP, G5R, G5I) >*/
  17627.     gf_(&zp, &g5r, &g5i);
  17628. /*<     4 T00R=( G1R+ G5R)* DZOT >*/
  17629. L4:
  17630.     t00r = (g1r + g5r) * dzot;
  17631. /*<       T00I=( G1I+ G5I)* DZOT >*/
  17632.     t00i = (g1i + g5i) * dzot;
  17633. /*<       T01R=( T00R+ DZ* G3R)*0.5 >*/
  17634.     t01r = (t00r + dz * g3r) * .5;
  17635. /*<       T01I=( T00I+ DZ* G3I)*0.5 >*/
  17636.     t01i = (t00i + dz * g3i) * .5;
  17637. /*<       T10R=(4.0* T01R- T00R)/3.0 >*/
  17638.     t10r = (t01r * 4. - t00r) / 3.;
  17639.  
  17640. /*     TEST CONVERGENCE OF 3 POINT ROMBERG RESULT. */
  17641.  
  17642. /*<       T10I=(4.0* T01I- T00I)/3.0 >*/
  17643.     t10i = (t01i * 4. - t00i) / 3.;
  17644. /*<       CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.) >*/
  17645.     test_(&t01r, &t10r, &te1r, &t01i, &t10i, &te1i, &c_b594);
  17646. /*<       IF( TE1I- RX) 5,5,6 >*/
  17647.     if (te1i - rx <= 0.) {
  17648.     goto L5;
  17649.     } else {
  17650.     goto L6;
  17651.     }
  17652. /*<     5 IF( TE1R- RX) 8,8,6 >*/
  17653. L5:
  17654.     if (te1r - rx <= 0.) {
  17655.     goto L8;
  17656.     } else {
  17657.     goto L6;
  17658.     }
  17659. /*<     6 ZP= Z+ DZ*0.25 >*/
  17660. L6:
  17661.     zp = z + dz * .25;
  17662. /*<       CALL GF( ZP, G2R, G2I) >*/
  17663.     gf_(&zp, &g2r, &g2i);
  17664. /*<       ZP= Z+ DZ*0.75 >*/
  17665.     zp = z + dz * .75;
  17666. /*<       CALL GF( ZP, G4R, G4I) >*/
  17667.     gf_(&zp, &g4r, &g4i);
  17668. /*<       T02R=( T01R+ DZOT*( G2R+ G4R))*0.5 >*/
  17669.     t02r = (t01r + dzot * (g2r + g4r)) * .5;
  17670. /*<       T02I=( T01I+ DZOT*( G2I+ G4I))*0.5 >*/
  17671.     t02i = (t01i + dzot * (g2i + g4i)) * .5;
  17672. /*<       T11R=(4.0* T02R- T01R)/3.0 >*/
  17673.     t11r = (t02r * 4. - t01r) / 3.;
  17674. /*<       T11I=(4.0* T02I- T01I)/3.0 >*/
  17675.     t11i = (t02i * 4. - t01i) / 3.;
  17676. /*<       T20R=(16.0* T11R- T10R)/15.0 >*/
  17677.     t20r = (t11r * 16. - t10r) / 15.;
  17678.  
  17679. /*     TEST CONVERGENCE OF 5 POINT ROMBERG RESULT. */
  17680.  
  17681. /*<       T20I=(16.0* T11I- T10I)/15.0 >*/
  17682.     t20i = (t11i * 16. - t10i) / 15.;
  17683. /*<       CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.) >*/
  17684.     test_(&t11r, &t20r, &te2r, &t11i, &t20i, &te2i, &c_b594);
  17685. /*<       IF( TE2I- RX) 7,7,14 >*/
  17686.     if (te2i - rx <= 0.) {
  17687.     goto L7;
  17688.     } else {
  17689.     goto L14;
  17690.     }
  17691. /*<     7 IF( TE2R- RX) 9,9,14 >*/
  17692. L7:
  17693.     if (te2r - rx <= 0.) {
  17694.     goto L9;
  17695.     } else {
  17696.     goto L14;
  17697.     }
  17698. /*<     8 SGR= SGR+ T10R >*/
  17699. L8:
  17700.     *sgr += t10r;
  17701. /*<       SGI= SGI+ T10I >*/
  17702.     *sgi += t10i;
  17703. /*<       NT= NT+2 >*/
  17704.     nt += 2;
  17705. /*<       GOTO 10 >*/
  17706.     goto L10;
  17707. /*<     9 SGR= SGR+ T20R >*/
  17708. L9:
  17709.     *sgr += t20r;
  17710. /*<       SGI= SGI+ T20I >*/
  17711.     *sgi += t20i;
  17712. /*<       NT= NT+1 >*/
  17713.     ++nt;
  17714. /*<    10 Z= Z+ DZ >*/
  17715. L10:
  17716.     z += dz;
  17717. /*<       IF( Z- ZEND) 11,17,17 >*/
  17718.     if (z - zend >= 0.) {
  17719.     goto L17;
  17720.     } else {
  17721.     goto L11;
  17722.     }
  17723. /*<    11 G1R= G5R >*/
  17724. L11:
  17725.     g1r = g5r;
  17726. /*<       G1I= G5I >*/
  17727.     g1i = g5i;
  17728. /*<       IF( NT- NTS) 1,12,12 >*/
  17729.     if (nt - nts >= 0) {
  17730.     goto L12;
  17731.     } else {
  17732.     goto L1;
  17733.     }
  17734.  
  17735. /*     DOUBLE STEP SIZE */
  17736.  
  17737. /*<    12 IF( NS- NX) 1,1,13 >*/
  17738. L12:
  17739.     if (ns - nx <= 0) {
  17740.     goto L1;
  17741.     } else {
  17742.     goto L13;
  17743.     }
  17744. /*<    13 NS= NS/2 >*/
  17745. L13:
  17746.     ns /= 2;
  17747. /*<       NT=1 >*/
  17748.     nt = 1;
  17749. /*<       GOTO 1 >*/
  17750.     goto L1;
  17751. /*<    14 NT=0 >*/
  17752. L14:
  17753.     nt = 0;
  17754. /*<       IF( NS- NM) 16,15,15 >*/
  17755.     if (ns - nm >= 0) {
  17756.     goto L15;
  17757.     } else {
  17758.     goto L16;
  17759.     }
  17760. /*<    15 WRITE( 6,20)  Z >*/
  17761. L15:
  17762.     s_wsfe(&io___1400);
  17763.     do_fio(&c__1, (char *)&z, (ftnlen)sizeof(doublereal));
  17764.     e_wsfe();
  17765.  
  17766. /*     HALVE STEP SIZE */
  17767.  
  17768. /*<       GOTO 9 >*/
  17769.     goto L9;
  17770. /*<    16 NS= NS*2 >*/
  17771. L16:
  17772.     ns <<= 1;
  17773. /*<       FNS= NS >*/
  17774.     fns = (doublereal) ns;
  17775. /*<       DZ= S/ FNS >*/
  17776.     dz = s / fns;
  17777. /*<       DZOT= DZ*0.5 >*/
  17778.     dzot = dz * .5;
  17779. /*<       G5R= G3R >*/
  17780.     g5r = g3r;
  17781. /*<       G5I= G3I >*/
  17782.     g5i = g3i;
  17783. /*<       G3R= G2R >*/
  17784.     g3r = g2r;
  17785. /*<       G3I= G2I >*/
  17786.     g3i = g2i;
  17787. /*<       GOTO 4 >*/
  17788.     goto L4;
  17789. /*<    17 CONTINUE >*/
  17790. L17:
  17791.  
  17792. /*     ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM */
  17793.  
  17794. /*<       IF( IJ) 19,18,19 >*/
  17795.     if (*ij != 0) {
  17796.     goto L19;
  17797.     } else {
  17798.     goto L18;
  17799.     }
  17800. /*<    18 SGR=2.*( SGR+ LOG(( SQRT( B* B+ S* S)+ S)/ B)) >*/
  17801. L18:
  17802.     *sgr = (*sgr + log((sqrt(*b * *b + s * s) + s) / *b)) * 2.;
  17803. /*<       SGI=2.* SGI >*/
  17804.     *sgi *= 2.;
  17805. /*<    19 CONTINUE >*/
  17806. L19:
  17807.  
  17808. /*<       RETURN >*/
  17809.     return 0;
  17810. /*<    20 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5) >*/
  17811. /*<       END >*/
  17812. } /* intx_ */
  17813.  
  17814. /* *** */
  17815. /*     DOUBLE PRECISION 6/4/85 */
  17816.  
  17817. /*<       FUNCTION ISEGNO( ITAGI, MX) >*/
  17818. integer isegno_(itagi, mx)
  17819. integer *itagi, *mx;
  17820. {
  17821.     /* Format strings */
  17822.     static char fmt_6[] = "(4x,\002CHECK DATA, PARAMETER SPECIFYING SEGMENT \
  17823. POSITION IN\002,\002 A GROUP OF EQUAL TAGS MUST NOT BE ZERO\002)";
  17824.     static char fmt_7[] = "(///,10x,\002NO SEGMENT HAS AN ITAG OF \002,i5)";
  17825.  
  17826.     /* System generated locals */
  17827.     integer ret_val, i__1;
  17828.  
  17829.     /* Builtin functions */
  17830.     integer s_wsfe(), e_wsfe();
  17831.     /* Subroutine */ int s_stop();
  17832.     integer do_fio();
  17833.  
  17834.     /* Local variables */
  17835.     static integer icnt, i;
  17836.  
  17837.     /* Fortran I/O blocks */
  17838.     static cilist io___1401 = { 0, 6, 0, fmt_6, 0 };
  17839.     static cilist io___1404 = { 0, 6, 0, fmt_7, 0 };
  17840.  
  17841.  
  17842. /* *** */
  17843.  
  17844. /*     ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THE */
  17845. /*     TAG NUMBER ITAGI.  IF ITAGI=0 SEGMENT NUMBER M IS RETURNED. */
  17846.  
  17847. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  17848. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  17849. /*<    >*/
  17850. /*<       IF( MX.GT.0) GOTO 1 >*/
  17851.     if (*mx > 0) {
  17852.     goto L1;
  17853.     }
  17854. /*<       WRITE( 6,6)  >*/
  17855.     s_wsfe(&io___1401);
  17856.     e_wsfe();
  17857. /*<       STOP >*/
  17858.     s_stop("", 0L);
  17859. /*<     1 ICNT=0 >*/
  17860. L1:
  17861.     icnt = 0;
  17862. /*<       IF( ITAGI.NE.0) GOTO 2 >*/
  17863.     if (*itagi != 0) {
  17864.     goto L2;
  17865.     }
  17866. /*<       ISEGNO= MX >*/
  17867.     ret_val = *mx;
  17868. /*<       RETURN >*/
  17869.     return ret_val;
  17870. /*<     2 IF( N.LT.1) GOTO 4 >*/
  17871. L2:
  17872.     if (data_1.n < 1) {
  17873.     goto L4;
  17874.     }
  17875. /*<       DO 3  I=1, N >*/
  17876.     i__1 = data_1.n;
  17877.     for (i = 1; i <= i__1; ++i) {
  17878. /*<       IF( ITAG( I).NE. ITAGI) GOTO 3 >*/
  17879.     if (data_1.itag[i - 1] != *itagi) {
  17880.         goto L3;
  17881.     }
  17882. /*<       ICNT= ICNT+1 >*/
  17883.     ++icnt;
  17884. /*<       IF( ICNT.EQ. MX) GOTO 5 >*/
  17885.     if (icnt == *mx) {
  17886.         goto L5;
  17887.     }
  17888. /*<     3 CONTINUE >*/
  17889. L3:
  17890.     ;
  17891.     }
  17892. /*<     4 WRITE( 6,7)  ITAGI >*/
  17893. L4:
  17894.     s_wsfe(&io___1404);
  17895.     do_fio(&c__1, (char *)&(*itagi), (ftnlen)sizeof(integer));
  17896.     e_wsfe();
  17897. /*<       STOP >*/
  17898.     s_stop("", 0L);
  17899. /*<     5 ISEGNO= I >*/
  17900. L5:
  17901.     ret_val = i;
  17902.  
  17903. /*<       RETURN >*/
  17904.     return ret_val;
  17905. /*<    >*/
  17906. /*<     7 FORMAT(///,10X,'NO SEGMENT HAS AN ITAG OF ',I5) >*/
  17907. /*<       END >*/
  17908. } /* isegno_ */
  17909.  
  17910. /* *** */
  17911. /*     DOUBLE PRECISION 6/4/85 */
  17912.  
  17913. /*<       SUBROUTINE LFACTR( A, NROW, IX1, IX2, IP) >*/
  17914. /* Subroutine */ int lfactr_(a, nrow, ix1, ix2, ip)
  17915. doublecomplex *a;
  17916. integer *nrow, *ix1, *ix2, *ip;
  17917. {
  17918.     /* Format strings */
  17919.     static char fmt_17[] = "(\002 \002,\002PIVOT(,I3,2H)=\002,1p,e16.8)";
  17920.  
  17921.     /* System generated locals */
  17922.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
  17923.     doublecomplex z__1, z__2;
  17924.  
  17925.     /* Builtin functions */
  17926.     void d_cnjg(), z_div();
  17927.     integer s_wsfe(), do_fio(), e_wsfe();
  17928.  
  17929.     /* Local variables */
  17930.     static integer iflg;
  17931.     static doublereal dmax_;
  17932.     static integer i, j, k, r;
  17933.     static doublereal elmag;
  17934.     static integer j1, j2;
  17935.     static logical l1, l2, l3;
  17936.     static integer r1, r2, pj, pr, jp1;
  17937.     static doublecomplex ajr;
  17938.     static integer j2p1, j2p2, ixj;
  17939.  
  17940.     /* Fortran I/O blocks */
  17941.     static cilist io___1426 = { 0, 6, 0, fmt_17, 0 };
  17942.  
  17943.  
  17944. /* *** */
  17945.  
  17946. /*     LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF 
  17947. */
  17948. /*     THE TRANSPOSED MATRIX IN CORE STORAGE.  THE GAUSS-DOOLITTLE */
  17949. /*     ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST */
  17950.  
  17951. /*     COURSE IN NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN 
  17952. */
  17953. /*     RALSTONS TEXT. */
  17954.  
  17955. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  17956. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  17957. /*<       COMPLEX  A, D, AJR >*/
  17958. /*<       INTEGER  R, R1, R2, PJ, PR >*/
  17959. /*<       LOGICAL  L1, L2, L3 >*/
  17960. /*<    >*/
  17961. /*<       COMMON  /SCRATM/ D( N2M) >*/
  17962. /*<       DIMENSION  A( NROW,1), IP( NROW) >*/
  17963.  
  17964. /*     INITIALIZE R1,R2,J1,J2 */
  17965.  
  17966. /*<       IFLG=0 >*/
  17967.     /* Parameter adjustments */
  17968.     --ip;
  17969.     a_dim1 = *nrow;
  17970.     a_offset = a_dim1 + 1;
  17971.     a -= a_offset;
  17972.  
  17973.     /* Function Body */
  17974.     iflg = 0;
  17975. /*<       L1= IX1.EQ.1.AND. IX2.EQ.2 >*/
  17976.     l1 = *ix1 == 1 && *ix2 == 2;
  17977. /*<       L2=( IX2-1).EQ. IX1 >*/
  17978.     l2 = *ix2 - 1 == *ix1;
  17979. /*<       L3= IX2.EQ. NBLSYM >*/
  17980.     l3 = *ix2 == matpar_1.nblsym;
  17981. /*<       IF( L1) GOTO 1 >*/
  17982.     if (l1) {
  17983.     goto L1;
  17984.     }
  17985. /*<       GOTO 2 >*/
  17986.     goto L2;
  17987. /*<     1 R1=1 >*/
  17988. L1:
  17989.     r1 = 1;
  17990. /*<       R2=2* NPSYM >*/
  17991.     r2 = matpar_1.npsym << 1;
  17992. /*<       J1=1 >*/
  17993.     j1 = 1;
  17994. /*<       J2=-1 >*/
  17995.     j2 = -1;
  17996. /*<       GOTO 5 >*/
  17997.     goto L5;
  17998. /*<     2 R1= NPSYM+1 >*/
  17999. L2:
  18000.     r1 = matpar_1.npsym + 1;
  18001. /*<       R2=2* NPSYM >*/
  18002.     r2 = matpar_1.npsym << 1;
  18003. /*<       J1=( IX1-1)* NPSYM+1 >*/
  18004.     j1 = (*ix1 - 1) * matpar_1.npsym + 1;
  18005. /*<       IF( L2) GOTO 3 >*/
  18006.     if (l2) {
  18007.     goto L3;
  18008.     }
  18009. /*<       GOTO 4 >*/
  18010.     goto L4;
  18011. /*<     3 J2= J1+ NPSYM-2 >*/
  18012. L3:
  18013.     j2 = j1 + matpar_1.npsym - 2;
  18014. /*<       GOTO 5 >*/
  18015.     goto L5;
  18016. /*<     4 J2= J1+ NPSYM-1 >*/
  18017. L4:
  18018.     j2 = j1 + matpar_1.npsym - 1;
  18019. /*<     5 IF( L3) R2= NPSYM+ NLSYM >*/
  18020. L5:
  18021.     if (l3) {
  18022.     r2 = matpar_1.npsym + matpar_1.nlsym;
  18023.     }
  18024.  
  18025. /*     STEP 1 */
  18026.  
  18027. /*<       DO 16  R= R1, R2 >*/
  18028.     i__1 = r2;
  18029.     for (r = r1; r <= i__1; ++r) {
  18030. /*<       DO 6  K= J1, NROW >*/
  18031.     i__2 = *nrow;
  18032.     for (k = j1; k <= i__2; ++k) {
  18033. /*<       D( K)= A( K, R) >*/
  18034.         i__3 = k - 1;
  18035.         i__4 = k + r * a_dim1;
  18036.         scratm_1.d[i__3].r = a[i__4].r, scratm_1.d[i__3].i = a[i__4].i;
  18037.  
  18038. /*     STEPS 2 AND 3 */
  18039.  
  18040. /*<     6 CONTINUE >*/
  18041. /* L6: */
  18042.     }
  18043. /*<       IF( L1.OR. L2) J2= J2+1 >*/
  18044.     if (l1 || l2) {
  18045.         ++j2;
  18046.     }
  18047. /*<       IF( J1.GT. J2) GOTO 9 >*/
  18048.     if (j1 > j2) {
  18049.         goto L9;
  18050.     }
  18051. /*<       IXJ=0 >*/
  18052.     ixj = 0;
  18053. /*<       DO 8  J= J1, J2 >*/
  18054.     i__2 = j2;
  18055.     for (j = j1; j <= i__2; ++j) {
  18056. /*<       IXJ= IXJ+1 >*/
  18057.         ++ixj;
  18058. /*<       PJ= IP( J) >*/
  18059.         pj = ip[j];
  18060. /*<       AJR= D( PJ) >*/
  18061.         i__3 = pj - 1;
  18062.         ajr.r = scratm_1.d[i__3].r, ajr.i = scratm_1.d[i__3].i;
  18063. /*<       A( J, R)= AJR >*/
  18064.         i__3 = j + r * a_dim1;
  18065.         a[i__3].r = ajr.r, a[i__3].i = ajr.i;
  18066. /*<       D( PJ)= D( J) >*/
  18067.         i__3 = pj - 1;
  18068.         i__4 = j - 1;
  18069.         scratm_1.d[i__3].r = scratm_1.d[i__4].r, scratm_1.d[i__3].i = 
  18070.             scratm_1.d[i__4].i;
  18071. /*<       JP1= J+1 >*/
  18072.         jp1 = j + 1;
  18073. /*<       DO 7  I= JP1, NROW >*/
  18074.         i__3 = *nrow;
  18075.         for (i = jp1; i <= i__3; ++i) {
  18076. /*<       D( I)= D( I)- A( I, IXJ)* AJR >*/
  18077.         i__4 = i - 1;
  18078.         i__5 = i - 1;
  18079.         i__6 = i + ixj * a_dim1;
  18080.         z__2.r = a[i__6].r * ajr.r - a[i__6].i * ajr.i, z__2.i = a[
  18081.             i__6].r * ajr.i + a[i__6].i * ajr.r;
  18082.         z__1.r = scratm_1.d[i__5].r - z__2.r, z__1.i = scratm_1.d[
  18083.             i__5].i - z__2.i;
  18084.         scratm_1.d[i__4].r = z__1.r, scratm_1.d[i__4].i = z__1.i;
  18085. /*<     7 CONTINUE >*/
  18086. /* L7: */
  18087.         }
  18088. /*<     8 CONTINUE >*/
  18089. /* L8: */
  18090.     }
  18091.  
  18092. /*     STEP 4 */
  18093.  
  18094. /*<     9 CONTINUE >*/
  18095. L9:
  18096. /*<       J2P1= J2+1 >*/
  18097.     j2p1 = j2 + 1;
  18098. /*<       IF( L1.OR. L2) GOTO 11 >*/
  18099.     if (l1 || l2) {
  18100.         goto L11;
  18101.     }
  18102. /*<       IF( NROW.LT. J2P1) GOTO 16 >*/
  18103.     if (*nrow < j2p1) {
  18104.         goto L16;
  18105.     }
  18106. /*<       DO 10  I= J2P1, NROW >*/
  18107.     i__2 = *nrow;
  18108.     for (i = j2p1; i <= i__2; ++i) {
  18109. /*<       A( I, R)= D( I) >*/
  18110.         i__3 = i + r * a_dim1;
  18111.         i__4 = i - 1;
  18112.         a[i__3].r = scratm_1.d[i__4].r, a[i__3].i = scratm_1.d[i__4].i;
  18113. /*<    10 CONTINUE >*/
  18114. /* L10: */
  18115.     }
  18116. /*<       GOTO 16 >*/
  18117.     goto L16;
  18118. /*<    11 DMAX= REAL( D( J2P1)* CONJG( D( J2P1))) >*/
  18119. L11:
  18120.     i__2 = j2p1 - 1;
  18121.     d_cnjg(&z__2, &scratm_1.d[j2p1 - 1]);
  18122.     z__1.r = scratm_1.d[i__2].r * z__2.r - scratm_1.d[i__2].i * z__2.i, 
  18123.         z__1.i = scratm_1.d[i__2].r * z__2.i + scratm_1.d[i__2].i * 
  18124.         z__2.r;
  18125.     dmax_ = z__1.r;
  18126. /*<       IP( J2P1)= J2P1 >*/
  18127.     ip[j2p1] = j2p1;
  18128. /*<       J2P2= J2+2 >*/
  18129.     j2p2 = j2 + 2;
  18130. /*<       IF( J2P2.GT. NROW) GOTO 13 >*/
  18131.     if (j2p2 > *nrow) {
  18132.         goto L13;
  18133.     }
  18134. /*<       DO 12  I= J2P2, NROW >*/
  18135.     i__2 = *nrow;
  18136.     for (i = j2p2; i <= i__2; ++i) {
  18137. /*<       ELMAG= REAL( D( I)* CONJG( D( I))) >*/
  18138.         i__3 = i - 1;
  18139.         d_cnjg(&z__2, &scratm_1.d[i - 1]);
  18140.         z__1.r = scratm_1.d[i__3].r * z__2.r - scratm_1.d[i__3].i * 
  18141.             z__2.i, z__1.i = scratm_1.d[i__3].r * z__2.i + scratm_1.d[
  18142.             i__3].i * z__2.r;
  18143.         elmag = z__1.r;
  18144. /*<       IF( ELMAG.LT. DMAX) GOTO 12 >*/
  18145.         if (elmag < dmax_) {
  18146.         goto L12;
  18147.         }
  18148. /*<       DMAX= ELMAG >*/
  18149.         dmax_ = elmag;
  18150. /*<       IP( J2P1)= I >*/
  18151.         ip[j2p1] = i;
  18152. /*<    12 CONTINUE >*/
  18153. L12:
  18154.         ;
  18155.     }
  18156. /*<    13 CONTINUE >*/
  18157. L13:
  18158. /*<       IF( DMAX.LT.1.D-10) IFLG=1 >*/
  18159.     if (dmax_ < 1e-10) {
  18160.         iflg = 1;
  18161.     }
  18162. /*<       PR= IP( J2P1) >*/
  18163.     pr = ip[j2p1];
  18164. /*<       A( J2P1, R)= D( PR) >*/
  18165.     i__2 = j2p1 + r * a_dim1;
  18166.     i__3 = pr - 1;
  18167.     a[i__2].r = scratm_1.d[i__3].r, a[i__2].i = scratm_1.d[i__3].i;
  18168.  
  18169. /*     STEP 5 */
  18170.  
  18171. /*<       D( PR)= D( J2P1) >*/
  18172.     i__2 = pr - 1;
  18173.     i__3 = j2p1 - 1;
  18174.     scratm_1.d[i__2].r = scratm_1.d[i__3].r, scratm_1.d[i__2].i = 
  18175.         scratm_1.d[i__3].i;
  18176. /*<       IF( J2P2.GT. NROW) GOTO 15 >*/
  18177.     if (j2p2 > *nrow) {
  18178.         goto L15;
  18179.     }
  18180. /*<       AJR=1./ A( J2P1, R) >*/
  18181.     z_div(&z__1, &c_b48, &a[j2p1 + r * a_dim1]);
  18182.     ajr.r = z__1.r, ajr.i = z__1.i;
  18183. /*<       DO 14  I= J2P2, NROW >*/
  18184.     i__2 = *nrow;
  18185.     for (i = j2p2; i <= i__2; ++i) {
  18186. /*<       A( I, R)= D( I)* AJR >*/
  18187.         i__3 = i + r * a_dim1;
  18188.         i__4 = i - 1;
  18189.         z__1.r = scratm_1.d[i__4].r * ajr.r - scratm_1.d[i__4].i * ajr.i, 
  18190.             z__1.i = scratm_1.d[i__4].r * ajr.i + scratm_1.d[i__4].i *
  18191.              ajr.r;
  18192.         a[i__3].r = z__1.r, a[i__3].i = z__1.i;
  18193. /*<    14 CONTINUE >*/
  18194. /* L14: */
  18195.     }
  18196. /*<    15 CONTINUE >*/
  18197. L15:
  18198. /*<       IF( IFLG.EQ.0) GOTO 16 >*/
  18199.     if (iflg == 0) {
  18200.         goto L16;
  18201.     }
  18202. /*<       WRITE( 6,17)  J2, DMAX >*/
  18203.     s_wsfe(&io___1426);
  18204.     do_fio(&c__1, (char *)&j2, (ftnlen)sizeof(integer));
  18205.     do_fio(&c__1, (char *)&dmax_, (ftnlen)sizeof(doublereal));
  18206.     e_wsfe();
  18207. /*<       IFLG=0 >*/
  18208.     iflg = 0;
  18209. /*<    16 CONTINUE >*/
  18210. L16:
  18211.     ;
  18212.     }
  18213.  
  18214. /*<       RETURN >*/
  18215.     return 0;
  18216. /*<    17 FORMAT(' ','PIVOT(,I3,2H)=',1P,E16.8) >*/
  18217. /*<       END >*/
  18218. } /* lfactr_ */
  18219.  
  18220. /* *** */
  18221. /*     DOUBLE PRECISION 6/4/85 */
  18222.  
  18223. /*<       SUBROUTINE LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI, ZLC) >*/
  18224. /* Subroutine */ int load_(ldtyp, ldtag, ldtagf, ldtagt, zlr, zli, zlc)
  18225. integer *ldtyp, *ldtag, *ldtagf, *ldtagt;
  18226. doublereal *zlr, *zli, *zlc;
  18227. {
  18228.     /* Initialized data */
  18229.  
  18230.     static struct {
  18231.     doublereal e_1[3];
  18232.     } equiv_0 = { 0., 1883698955., 0. };
  18233.  
  18234.  
  18235.     /* Format strings */
  18236.     static char fmt_25[] = "(//,7x,\002LOCATION\002,10x,\002RESISTANCE\002,3\
  18237. x,\002INDUCTANCE\002,2x,\002CAPACITANCE\002,7x,\002IMPEDANCE (OHMS)\002,5x\
  18238. ,\002CONDUCTIVITY\002,4x,\002TYPE\002,/,4x,\002ITAG\002,\002 FROM THRU\002,1\
  18239. 0x,\002OHMS\002,8x,\002HENRYS\002,7x,\002FARADS\002,8x,\002REAL\002,6x,\002I\
  18240. MAGINARY\002,4x,\002MHOS/METER\002)";
  18241.     static char fmt_26[] = "(/,10x,\002NOTE, SOME OF THE ABOVE SEGMENTS HAVE\
  18242.  BEEN LOADED\002,\002 TWICE - IMPEDANCES ADDED\002)";
  18243.     static char fmt_27[] = "(/,10x,\002IMPROPER LOAD TYPE CHOOSEN, REQUESTED\
  18244.  TYPE IS \002,i3)";
  18245.     static char fmt_29[] = "(\002 ERROR - LOADING MAY NOT BE ADDED TO SEGMEN\
  18246. TS IN N.G.F.\002\002 SECTION\002)";
  18247.     static char fmt_28[] = "(/,10x,\002LOADING DATA CARD ERROR, NO SEGMENT H\
  18248. AS AN ITAG =\002,i5)";
  18249.  
  18250.     /* System generated locals */
  18251.     integer i__1, i__2, i__3, i__4;
  18252.     doublereal d__1, d__2;
  18253.     doublecomplex z__1, z__2, z__3, z__4, z__5;
  18254.  
  18255.     /* Builtin functions */
  18256.     integer s_wsfe(), e_wsfe(), do_fio();
  18257.     /* Subroutine */ int s_stop();
  18258.     void z_div();
  18259.     double d_imag();
  18260.  
  18261.     /* Local variables */
  18262.     static integer ichk;
  18263. #define tpcj ((doublecomplex *)&equiv_0)
  18264.     static integer jump;
  18265.     extern /* Subroutine */ int prnt_();
  18266.     extern /* Double Complex */ int zint_();
  18267.     static integer i, iwarn, istep;
  18268. #define tpcjx ((doublereal *)&equiv_0)
  18269.     static integer l1, l2;
  18270.     static doublecomplex zt;
  18271.     static integer ldtags, nop;
  18272.  
  18273.     /* Fortran I/O blocks */
  18274.     static cilist io___1429 = { 0, 6, 0, fmt_25, 0 };
  18275.     static cilist io___1433 = { 0, 6, 0, fmt_26, 0 };
  18276.     static cilist io___1438 = { 0, 6, 0, fmt_27, 0 };
  18277.     static cilist io___1442 = { 0, 6, 0, fmt_29, 0 };
  18278.     static cilist io___1443 = { 0, 6, 0, fmt_28, 0 };
  18279.  
  18280.  
  18281. /* *** */
  18282.  
  18283. /*     LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUS */
  18284. /*     TYPES OF LOADING */
  18285.  
  18286. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  18287. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  18288. /*<       COMPLEX  ZARRAY, ZT, TPCJ, ZINT >*/
  18289. /*<    >*/
  18290. /*<       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
  18291. /*<    >*/
  18292. /*<       EQUIVALENCE(TPCJ,TPCJX) >*/
  18293.  
  18294. /*     WRITE(6,HEADING) */
  18295.  
  18296. /*<       DATA   TPCJX/0.,1.883698955D+9/ >*/
  18297.     /* Parameter adjustments */
  18298.     --zlc;
  18299.     --zli;
  18300.     --zlr;
  18301.     --ldtagt;
  18302.     --ldtagf;
  18303.     --ldtag;
  18304.     --ldtyp;
  18305.  
  18306.     /* Function Body */
  18307.  
  18308. /*     INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING */
  18309. /*     INFORMATION. */
  18310.  
  18311. /*<       WRITE( 6,25)  >*/
  18312.     s_wsfe(&io___1429);
  18313.     e_wsfe();
  18314. /*<       DO 1  I= N2, N >*/
  18315.     i__1 = data_1.n;
  18316.     for (i = data_1.n2; i <= i__1; ++i) {
  18317. /*<     1 ZARRAY( I)=(0.,0.) >*/
  18318. /* L1: */
  18319.     i__2 = i - 1;
  18320.     zload_1.zarray[i__2].r = 0., zload_1.zarray[i__2].i = 0.;
  18321.     }
  18322.  
  18323. /*     CYCLE OVER LOADING CARDS */
  18324.  
  18325. /*<       IWARN=0 >*/
  18326.     iwarn = 0;
  18327. /*<       ISTEP=0 >*/
  18328.     istep = 0;
  18329. /*<     2 ISTEP= ISTEP+1 >*/
  18330. L2:
  18331.     ++istep;
  18332. /*<       IF( ISTEP.LE. NLOAD) GOTO 5 >*/
  18333.     if (istep <= zload_1.nload) {
  18334.     goto L5;
  18335.     }
  18336. /*<       IF( IWARN.EQ.1) WRITE( 6,26)  >*/
  18337.     if (iwarn == 1) {
  18338.     s_wsfe(&io___1433);
  18339.     e_wsfe();
  18340.     }
  18341. /*<       IF( N1+2* M1.GT.0) GOTO 4 >*/
  18342.     if (data_1.n1 + (data_1.m1 << 1) > 0) {
  18343.     goto L4;
  18344.     }
  18345. /*<       NOP= N/ NP >*/
  18346.     nop = data_1.n / data_1.np;
  18347. /*<       IF( NOP.EQ.1) GOTO 4 >*/
  18348.     if (nop == 1) {
  18349.     goto L4;
  18350.     }
  18351. /*<       DO 3  I=1, NP >*/
  18352.     i__2 = data_1.np;
  18353.     for (i = 1; i <= i__2; ++i) {
  18354. /*<       ZT= ZARRAY( I) >*/
  18355.     i__1 = i - 1;
  18356.     zt.r = zload_1.zarray[i__1].r, zt.i = zload_1.zarray[i__1].i;
  18357. /*<       L1= I >*/
  18358.     l1 = i;
  18359. /*<       DO 3  L2=2, NOP >*/
  18360.     i__1 = nop;
  18361.     for (l2 = 2; l2 <= i__1; ++l2) {
  18362. /*<       L1= L1+ NP >*/
  18363.         l1 += data_1.np;
  18364. /*<     3 ZARRAY( L1)= ZT >*/
  18365. /* L3: */
  18366.         i__3 = l1 - 1;
  18367.         zload_1.zarray[i__3].r = zt.r, zload_1.zarray[i__3].i = zt.i;
  18368.     }
  18369.     }
  18370. /*<     4 RETURN >*/
  18371. L4:
  18372.     return 0;
  18373. /*<     5 IF( LDTYP( ISTEP).LE.5) GOTO 6 >*/
  18374. L5:
  18375.     if (ldtyp[istep] <= 5) {
  18376.     goto L6;
  18377.     }
  18378. /*<       WRITE( 6,27)  LDTYP( ISTEP) >*/
  18379.     s_wsfe(&io___1438);
  18380.     do_fio(&c__1, (char *)&ldtyp[istep], (ftnlen)sizeof(integer));
  18381.     e_wsfe();
  18382. /*<       STOP >*/
  18383.     s_stop("", 0L);
  18384. /*<     6 LDTAGS= LDTAG( ISTEP) >*/
  18385. L6:
  18386.     ldtags = ldtag[istep];
  18387. /*<       JUMP= LDTYP( ISTEP)+1 >*/
  18388.     jump = ldtyp[istep] + 1;
  18389.  
  18390. /*     SEARCH SEGMENTS FOR PROPER ITAGS */
  18391.  
  18392. /*<       ICHK=0 >*/
  18393.     ichk = 0;
  18394. /*<       L1= N2 >*/
  18395.     l1 = data_1.n2;
  18396. /*<       L2= N >*/
  18397.     l2 = data_1.n;
  18398. /*<       IF( LDTAGS.NE.0) GOTO 7 >*/
  18399.     if (ldtags != 0) {
  18400.     goto L7;
  18401.     }
  18402. /*<       IF( LDTAGF( ISTEP).EQ.0.AND. LDTAGT( ISTEP).EQ.0) GOTO 7 >*/
  18403.     if (ldtagf[istep] == 0 && ldtagt[istep] == 0) {
  18404.     goto L7;
  18405.     }
  18406. /*<       L1= LDTAGF( ISTEP) >*/
  18407.     l1 = ldtagf[istep];
  18408. /*<       L2= LDTAGT( ISTEP) >*/
  18409.     l2 = ldtagt[istep];
  18410. /*<       IF( L1.GT. N1) GOTO 7 >*/
  18411.     if (l1 > data_1.n1) {
  18412.     goto L7;
  18413.     }
  18414. /*<       WRITE( 6,29)  >*/
  18415.     s_wsfe(&io___1442);
  18416.     e_wsfe();
  18417. /*<       STOP >*/
  18418.     s_stop("", 0L);
  18419. /*<     7 DO 17  I= L1, L2 >*/
  18420. L7:
  18421.     i__3 = l2;
  18422.     for (i = l1; i <= i__3; ++i) {
  18423. /*<       IF( LDTAGS.EQ.0) GOTO 8 >*/
  18424.     if (ldtags == 0) {
  18425.         goto L8;
  18426.     }
  18427. /*<       IF( LDTAGS.NE. ITAG( I)) GOTO 17 >*/
  18428.     if (ldtags != data_1.itag[i - 1]) {
  18429.         goto L17;
  18430.     }
  18431. /*<       IF( LDTAGF( ISTEP).EQ.0) GOTO 8 >*/
  18432.     if (ldtagf[istep] == 0) {
  18433.         goto L8;
  18434.     }
  18435. /*<       ICHK= ICHK+1 >*/
  18436.     ++ichk;
  18437. /*<       IF( ICHK.GE. LDTAGF( ISTEP).AND. ICHK.LE. LDTAGT( ISTEP)) GOTO 9 >*/
  18438.     if (ichk >= ldtagf[istep] && ichk <= ldtagt[istep]) {
  18439.         goto L9;
  18440.     }
  18441. /*<       GOTO 17 >*/
  18442.     goto L17;
  18443.  
  18444. /*     CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIAT
  18445. E */
  18446. /*     SECTION FOR LOADING TYPE */
  18447.  
  18448. /*<     8 ICHK=1 >*/
  18449. L8:
  18450.     ichk = 1;
  18451. /*<     9 GOTO (10,11,12,13,14,15), JUMP >*/
  18452. L9:
  18453.     switch ((int)jump) {
  18454.         case 1:  goto L10;
  18455.         case 2:  goto L11;
  18456.         case 3:  goto L12;
  18457.         case 4:  goto L13;
  18458.         case 5:  goto L14;
  18459.         case 6:  goto L15;
  18460.     }
  18461. /*<    10 ZT= ZLR( ISTEP)/ SI( I)+ TPCJ* ZLI( ISTEP)/( SI( I)* WLAM) >*/
  18462. L10:
  18463.     d__1 = zlr[istep] / data_1.si[i - 1];
  18464.     i__1 = istep;
  18465.     z__3.r = zli[i__1] * tpcj->r, z__3.i = zli[i__1] * tpcj->i;
  18466.     d__2 = data_1.si[i - 1] * data_1.wlam;
  18467.     z__2.r = z__3.r / d__2, z__2.i = z__3.i / d__2;
  18468.     z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
  18469.     zt.r = z__1.r, zt.i = z__1.i;
  18470. /*<    >*/
  18471.     if ((d__1 = zlc[istep], abs(d__1)) > 1e-20) {
  18472.         z__3.r = data_1.wlam, z__3.i = 0.;
  18473.         i__1 = i - 1;
  18474.         z__5.r = data_1.si[i__1] * tpcj->r, z__5.i = data_1.si[i__1] * 
  18475.             tpcj->i;
  18476.         i__2 = istep;
  18477.         z__4.r = zlc[i__2] * z__5.r, z__4.i = zlc[i__2] * z__5.i;
  18478.         z_div(&z__2, &z__3, &z__4);
  18479.         z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
  18480.         zt.r = z__1.r, zt.i = z__1.i;
  18481.     }
  18482. /*<       GOTO 16 >*/
  18483.     goto L16;
  18484. /*<    11 ZT= TPCJ* SI( I)* ZLC( ISTEP)/ WLAM >*/
  18485. L11:
  18486.     i__1 = i - 1;
  18487.     z__3.r = data_1.si[i__1] * tpcj->r, z__3.i = data_1.si[i__1] * 
  18488.         tpcj->i;
  18489.     i__2 = istep;
  18490.     z__2.r = zlc[i__2] * z__3.r, z__2.i = zlc[i__2] * z__3.i;
  18491.     z__1.r = z__2.r / data_1.wlam, z__1.i = z__2.i / data_1.wlam;
  18492.     zt.r = z__1.r, zt.i = z__1.i;
  18493. /*<    >*/
  18494.     if ((d__1 = zli[istep], abs(d__1)) > 1e-20) {
  18495.         d__2 = data_1.si[i - 1] * data_1.wlam;
  18496.         z__3.r = d__2, z__3.i = 0.;
  18497.         i__1 = istep;
  18498.         z__4.r = zli[i__1] * tpcj->r, z__4.i = zli[i__1] * tpcj->i;
  18499.         z_div(&z__2, &z__3, &z__4);
  18500.         z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
  18501.         zt.r = z__1.r, zt.i = z__1.i;
  18502.     }
  18503. /*<       IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)/ ZLR( ISTEP) >*/
  18504.     if ((d__1 = zlr[istep], abs(d__1)) > 1e-20) {
  18505.         d__2 = data_1.si[i - 1] / zlr[istep];
  18506.         z__1.r = zt.r + d__2, z__1.i = zt.i;
  18507.         zt.r = z__1.r, zt.i = z__1.i;
  18508.     }
  18509. /*<       ZT=1./ ZT >*/
  18510.     z_div(&z__1, &c_b48, &zt);
  18511.     zt.r = z__1.r, zt.i = z__1.i;
  18512. /*<       GOTO 16 >*/
  18513.     goto L16;
  18514. /*<    12 ZT= ZLR( ISTEP)* WLAM+ TPCJ* ZLI( ISTEP) >*/
  18515. L12:
  18516.     d__1 = zlr[istep] * data_1.wlam;
  18517.     i__1 = istep;
  18518.     z__2.r = zli[i__1] * tpcj->r, z__2.i = zli[i__1] * tpcj->i;
  18519.     z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
  18520.     zt.r = z__1.r, zt.i = z__1.i;
  18521. /*<    >*/
  18522.     if ((d__1 = zlc[istep], abs(d__1)) > 1e-20) {
  18523.         i__1 = i - 1;
  18524.         z__5.r = data_1.si[i__1] * tpcj->r, z__5.i = data_1.si[i__1] * 
  18525.             tpcj->i;
  18526.         i__2 = i - 1;
  18527.         z__4.r = data_1.si[i__2] * z__5.r, z__4.i = data_1.si[i__2] * 
  18528.             z__5.i;
  18529.         i__4 = istep;
  18530.         z__3.r = zlc[i__4] * z__4.r, z__3.i = zlc[i__4] * z__4.i;
  18531.         z_div(&z__2, &c_b48, &z__3);
  18532.         z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
  18533.         zt.r = z__1.r, zt.i = z__1.i;
  18534.     }
  18535. /*<       GOTO 16 >*/
  18536.     goto L16;
  18537. /*<    13 ZT= TPCJ* SI( I)* SI( I)* ZLC( ISTEP) >*/
  18538. L13:
  18539.     i__1 = i - 1;
  18540.     z__3.r = data_1.si[i__1] * tpcj->r, z__3.i = data_1.si[i__1] * 
  18541.         tpcj->i;
  18542.     i__2 = i - 1;
  18543.     z__2.r = data_1.si[i__2] * z__3.r, z__2.i = data_1.si[i__2] * z__3.i;
  18544.     i__4 = istep;
  18545.     z__1.r = zlc[i__4] * z__2.r, z__1.i = zlc[i__4] * z__2.i;
  18546.     zt.r = z__1.r, zt.i = z__1.i;
  18547. /*<       IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* ZLI( ISTEP)) >*/
  18548.     if ((d__1 = zli[istep], abs(d__1)) > 1e-20) {
  18549.         i__1 = istep;
  18550.         z__3.r = zli[i__1] * tpcj->r, z__3.i = zli[i__1] * tpcj->i;
  18551.         z_div(&z__2, &c_b48, &z__3);
  18552.         z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
  18553.         zt.r = z__1.r, zt.i = z__1.i;
  18554.     }
  18555. /*<       IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+1./( ZLR( ISTEP)* WLAM) >*/
  18556.     if ((d__1 = zlr[istep], abs(d__1)) > 1e-20) {
  18557.         d__2 = 1. / (zlr[istep] * data_1.wlam);
  18558.         z__1.r = zt.r + d__2, z__1.i = zt.i;
  18559.         zt.r = z__1.r, zt.i = z__1.i;
  18560.     }
  18561. /*<       ZT=1./ ZT >*/
  18562.     z_div(&z__1, &c_b48, &zt);
  18563.     zt.r = z__1.r, zt.i = z__1.i;
  18564. /*<       GOTO 16 >*/
  18565.     goto L16;
  18566. /*<    14 ZT= CMPLX( ZLR( ISTEP), ZLI( ISTEP))/ SI( I) >*/
  18567. L14:
  18568.     i__1 = istep;
  18569.     i__2 = istep;
  18570.     z__2.r = zlr[i__1], z__2.i = zli[i__2];
  18571.     i__4 = i - 1;
  18572.     z__1.r = z__2.r / data_1.si[i__4], z__1.i = z__2.i / data_1.si[i__4];
  18573.     zt.r = z__1.r, zt.i = z__1.i;
  18574. /*<       GOTO 16 >*/
  18575.     goto L16;
  18576. /*<    15 ZT= ZINT( ZLR( ISTEP)* WLAM, BI( I)) >*/
  18577. L15:
  18578.     d__1 = zlr[istep] * data_1.wlam;
  18579.     zint_(&z__1, &d__1, &data_1.bi[i - 1]);
  18580.     zt.r = z__1.r, zt.i = z__1.i;
  18581. /*<    >*/
  18582. L16:
  18583.     i__1 = i - 1;
  18584.     if ((d__1 = zload_1.zarray[i__1].r, abs(d__1)) + (d__2 = d_imag(&
  18585.         zload_1.zarray[i - 1]), abs(d__2)) > 1e-20) {
  18586.         iwarn = 1;
  18587.     }
  18588. /*<       ZARRAY( I)= ZARRAY( I)+ ZT >*/
  18589.     i__1 = i - 1;
  18590.     i__2 = i - 1;
  18591.     z__1.r = zload_1.zarray[i__2].r + zt.r, z__1.i = zload_1.zarray[i__2]
  18592.         .i + zt.i;
  18593.     zload_1.zarray[i__1].r = z__1.r, zload_1.zarray[i__1].i = z__1.i;
  18594. /*<    17 CONTINUE >*/
  18595. L17:
  18596.     ;
  18597.     }
  18598. /*<       IF( ICHK.NE.0) GOTO 18 >*/
  18599.     if (ichk != 0) {
  18600.     goto L18;
  18601.     }
  18602. /*<       WRITE( 6,28)  LDTAGS >*/
  18603.     s_wsfe(&io___1443);
  18604.     do_fio(&c__1, (char *)&ldtags, (ftnlen)sizeof(integer));
  18605.     e_wsfe();
  18606.  
  18607. /*     PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT */
  18608.  
  18609. /*<       STOP >*/
  18610.     s_stop("", 0L);
  18611. /*<    18 GOTO (19,20,21,22,23,24), JUMP >*/
  18612. L18:
  18613.     switch ((int)jump) {
  18614.     case 1:  goto L19;
  18615.     case 2:  goto L20;
  18616.     case 3:  goto L21;
  18617.     case 4:  goto L22;
  18618.     case 5:  goto L23;
  18619.     case 6:  goto L24;
  18620.     }
  18621. /*<    >*/
  18622. L19:
  18623.     prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
  18624.         zlc[istep], &c_b594, &c_b594, &c_b594, " SERIES ", &c__2, 8L);
  18625. /*<       GOTO 2 >*/
  18626.     goto L2;
  18627. /*<    >*/
  18628. L20:
  18629.     prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
  18630.         zlc[istep], &c_b594, &c_b594, &c_b594, "PARALLEL", &c__2, 8L);
  18631. /*<       GOTO 2 >*/
  18632.     goto L2;
  18633. /*<    >*/
  18634. L21:
  18635.     prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
  18636.         zlc[istep], &c_b594, &c_b594, &c_b594, "SERIES (PER METER),5", 
  18637.         20L);
  18638. /*<       GOTO 2 >*/
  18639.     goto L2;
  18640. /*<    >*/
  18641. L22:
  18642.     prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
  18643.         zlc[istep], &c_b594, &c_b594, &c_b594, "PARALLEL (PER METER)", &
  18644.         c__5, 20L);
  18645. /*<       GOTO 2 >*/
  18646.     goto L2;
  18647. /*<    >*/
  18648. L23:
  18649.     prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &c_b594, &c_b594, &c_b594, 
  18650.         &zlr[istep], &zli[istep], &c_b594, "FIXED IMPEDANCE ", &c__4, 16L)
  18651.         ;
  18652. /*<       GOTO 2 >*/
  18653.     goto L2;
  18654. /*<    >*/
  18655. L24:
  18656.     prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &c_b594, &c_b594, &c_b594, 
  18657.         &c_b594, &c_b594, &zlr[istep], "  WIRE  ", &c__2, 8L);
  18658.  
  18659. /*<       GOTO 2 >*/
  18660.     goto L2;
  18661. /*<    >*/
  18662. /*<    >*/
  18663. /*<    >*/
  18664. /*<    >*/
  18665. /*<    >*/
  18666. /*<       END >*/
  18667. } /* load_ */
  18668.  
  18669. #undef tpcjx
  18670. #undef tpcj
  18671.  
  18672.  
  18673. /* *** */
  18674. /*     DOUBLE PRECISION 6/4/85 */
  18675.  
  18676. /*<       SUBROUTINE LTSOLV( A, NROW, IX, B, NEQ, NRH, IFL1, IFL2) >*/
  18677. /* Subroutine */ int ltsolv_(a, nrow, ix, b, neq, nrh, ifl1, ifl2)
  18678. doublecomplex *a;
  18679. integer *nrow, *ix;
  18680. doublecomplex *b;
  18681. integer *neq, *nrh, *ifl1, *ifl2;
  18682. {
  18683.     /* System generated locals */
  18684.     integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, 
  18685.         i__6;
  18686.     doublecomplex z__1, z__2;
  18687.  
  18688.     /* Builtin functions */
  18689.     void z_div();
  18690.  
  18691.     /* Local variables */
  18692.     static integer i, j, k, i2, k2, ixblk1, ic, kp;
  18693.     extern /* Subroutine */ int blckin_();
  18694.     static integer jm1, jp1, ixi, jst;
  18695.     static doublecomplex sum;
  18696.  
  18697. /* *** */
  18698.  
  18699. /*     LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROW 
  18700. */
  18701. /*     VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OF 
  18702. */
  18703. /*     THE ORIGINAL COEFFICIENT MATRIX.  THE LU(T) DECOMPOSITION IS */
  18704. /*     STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 IN */
  18705. /*     BLOCKS OF DESCENDING ORDER. */
  18706.  
  18707. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  18708. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  18709. /*<       COMPLEX  A, B, Y, SUM >*/
  18710. /*<    >*/
  18711. /*<       COMMON  /SCRATM/ Y( N2M) >*/
  18712.  
  18713. /*     FORWARD SUBSTITUTION */
  18714.  
  18715. /*<       DIMENSION  A( NROW, NROW), B( NEQ, NRH), IX( NEQ) >*/
  18716. /*<       I2=2* NPSYM* NROW >*/
  18717.     /* Parameter adjustments */
  18718.     b_dim1 = *neq;
  18719.     b_offset = b_dim1 + 1;
  18720.     b -= b_offset;
  18721.     --ix;
  18722.     a_dim1 = *nrow;
  18723.     a_offset = a_dim1 + 1;
  18724.     a -= a_offset;
  18725.  
  18726.     /* Function Body */
  18727.     i2 = (matpar_1.npsym << 1) * *nrow;
  18728. /*<       DO 4  IXBLK1=1, NBLSYM >*/
  18729.     i__1 = matpar_1.nblsym;
  18730.     for (ixblk1 = 1; ixblk1 <= i__1; ++ixblk1) {
  18731. /*<       CALL BLCKIN( A, IFL1,1, I2,1,121) >*/
  18732.     blckin_(&a[a_offset], ifl1, &c__1, &i2, &c__1, &c__121);
  18733. /*<       K2= NPSYM >*/
  18734.     k2 = matpar_1.npsym;
  18735. /*<       IF( IXBLK1.EQ. NBLSYM) K2= NLSYM >*/
  18736.     if (ixblk1 == matpar_1.nblsym) {
  18737.         k2 = matpar_1.nlsym;
  18738.     }
  18739. /*<       JST=( IXBLK1-1)* NPSYM >*/
  18740.     jst = (ixblk1 - 1) * matpar_1.npsym;
  18741. /*<       DO 4  IC=1, NRH >*/
  18742.     i__2 = *nrh;
  18743.     for (ic = 1; ic <= i__2; ++ic) {
  18744. /*<       J= JST >*/
  18745.         j = jst;
  18746. /*<       DO 3  K=1, K2 >*/
  18747.         i__3 = k2;
  18748.         for (k = 1; k <= i__3; ++k) {
  18749. /*<       JM1= J >*/
  18750.         jm1 = j;
  18751. /*<       J= J+1 >*/
  18752.         ++j;
  18753. /*<       SUM=(0.,0.) >*/
  18754.         sum.r = 0., sum.i = 0.;
  18755. /*<       IF( JM1.LT.1) GOTO 2 >*/
  18756.         if (jm1 < 1) {
  18757.             goto L2;
  18758.         }
  18759. /*<       DO 1  I=1, JM1 >*/
  18760.         i__4 = jm1;
  18761.         for (i = 1; i <= i__4; ++i) {
  18762. /*<     1 SUM= SUM+ A( I, K)* B( I, IC) >*/
  18763. /* L1: */
  18764.             i__5 = i + k * a_dim1;
  18765.             i__6 = i + ic * b_dim1;
  18766.             z__2.r = a[i__5].r * b[i__6].r - a[i__5].i * b[i__6].i, 
  18767.                 z__2.i = a[i__5].r * b[i__6].i + a[i__5].i * b[
  18768.                 i__6].r;
  18769.             z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  18770.             sum.r = z__1.r, sum.i = z__1.i;
  18771.         }
  18772. /*<     2 B( J, IC)=( B( J, IC)- SUM)/ A( J, K) >*/
  18773. L2:
  18774.         i__5 = j + ic * b_dim1;
  18775.         i__6 = j + ic * b_dim1;
  18776.         z__2.r = b[i__6].r - sum.r, z__2.i = b[i__6].i - sum.i;
  18777.         z_div(&z__1, &z__2, &a[j + k * a_dim1]);
  18778.         b[i__5].r = z__1.r, b[i__5].i = z__1.i;
  18779. /*<     3 CONTINUE >*/
  18780. /* L3: */
  18781.         }
  18782.  
  18783. /*     BACKWARD SUBSTITUTION */
  18784.  
  18785. /*<     4 CONTINUE >*/
  18786. /* L4: */
  18787.     }
  18788.     }
  18789. /*<       JST= NROW+1 >*/
  18790.     jst = *nrow + 1;
  18791. /*<       DO 8  IXBLK1=1, NBLSYM >*/
  18792.     i__2 = matpar_1.nblsym;
  18793.     for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
  18794. /*<       CALL BLCKIN( A, IFL2,1, I2,1,122) >*/
  18795.     blckin_(&a[a_offset], ifl2, &c__1, &i2, &c__1, &c__122);
  18796. /*<       K2= NPSYM >*/
  18797.     k2 = matpar_1.npsym;
  18798. /*<       IF( IXBLK1.EQ.1) K2= NLSYM >*/
  18799.     if (ixblk1 == 1) {
  18800.         k2 = matpar_1.nlsym;
  18801.     }
  18802. /*<       DO 7  IC=1, NRH >*/
  18803.     i__1 = *nrh;
  18804.     for (ic = 1; ic <= i__1; ++ic) {
  18805. /*<       KP= K2+1 >*/
  18806.         kp = k2 + 1;
  18807. /*<       J= JST >*/
  18808.         j = jst;
  18809. /*<       DO 6  K=1, K2 >*/
  18810.         i__3 = k2;
  18811.         for (k = 1; k <= i__3; ++k) {
  18812. /*<       KP= KP-1 >*/
  18813.         --kp;
  18814. /*<       JP1= J >*/
  18815.         jp1 = j;
  18816. /*<       J= J-1 >*/
  18817.         --j;
  18818. /*<       SUM=(0.,0.) >*/
  18819.         sum.r = 0., sum.i = 0.;
  18820. /*<       IF( NROW.LT. JP1) GOTO 6 >*/
  18821.         if (*nrow < jp1) {
  18822.             goto L6;
  18823.         }
  18824. /*<       DO 5  I= JP1, NROW >*/
  18825.         i__5 = *nrow;
  18826.         for (i = jp1; i <= i__5; ++i) {
  18827. /*<     5 SUM= SUM+ A( I, KP)* B( I, IC) >*/
  18828. /* L5: */
  18829.             i__6 = i + kp * a_dim1;
  18830.             i__4 = i + ic * b_dim1;
  18831.             z__2.r = a[i__6].r * b[i__4].r - a[i__6].i * b[i__4].i, 
  18832.                 z__2.i = a[i__6].r * b[i__4].i + a[i__6].i * b[
  18833.                 i__4].r;
  18834.             z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  18835.             sum.r = z__1.r, sum.i = z__1.i;
  18836.         }
  18837. /*<       B( J, IC)= B( J, IC)- SUM >*/
  18838.         i__6 = j + ic * b_dim1;
  18839.         i__4 = j + ic * b_dim1;
  18840.         z__1.r = b[i__4].r - sum.r, z__1.i = b[i__4].i - sum.i;
  18841.         b[i__6].r = z__1.r, b[i__6].i = z__1.i;
  18842. /*<     6 CONTINUE >*/
  18843. L6:
  18844.         ;
  18845.         }
  18846. /*<     7 CONTINUE >*/
  18847. /* L7: */
  18848.     }
  18849.  
  18850. /*     UNSCRAMBLE SOLUTION */
  18851.  
  18852. /*<     8 JST= JST- K2 >*/
  18853. /* L8: */
  18854.     jst -= k2;
  18855.     }
  18856. /*<       DO 10  IC=1, NRH >*/
  18857.     i__2 = *nrh;
  18858.     for (ic = 1; ic <= i__2; ++ic) {
  18859. /*<       DO 9  I=1, NROW >*/
  18860.     i__1 = *nrow;
  18861.     for (i = 1; i <= i__1; ++i) {
  18862. /*<       IXI= IX( I) >*/
  18863.         ixi = ix[i];
  18864. /*<     9 Y( IXI)= B( I, IC) >*/
  18865. /* L9: */
  18866.         i__3 = ixi - 1;
  18867.         i__6 = i + ic * b_dim1;
  18868.         scratm_2.y[i__3].r = b[i__6].r, scratm_2.y[i__3].i = b[i__6].i;
  18869.     }
  18870. /*<       DO 10  I=1, NROW >*/
  18871.     i__3 = *nrow;
  18872.     for (i = 1; i <= i__3; ++i) {
  18873. /*<    10 B( I, IC)= Y( I) >*/
  18874. /* L10: */
  18875.         i__6 = i + ic * b_dim1;
  18876.         i__1 = i - 1;
  18877.         b[i__6].r = scratm_2.y[i__1].r, b[i__6].i = scratm_2.y[i__1].i;
  18878.     }
  18879.     }
  18880. /*<       RETURN >*/
  18881.     return 0;
  18882. /*<       END >*/
  18883. } /* ltsolv_ */
  18884.  
  18885. /* *** */
  18886. /*     DOUBLE PRECISION 6/4/85 */
  18887.  
  18888. /*<       SUBROUTINE LUNSCR( A, NROW, NOP, IX, IP, IU2, IU3, IU4) >*/
  18889. /* Subroutine */ int lunscr_(a, nrow, nop, ix, ip, iu2, iu3, iu4)
  18890. doublecomplex *a;
  18891. integer *nrow, *nop, *ix, *ip, *iu2, *iu3, *iu4;
  18892. {
  18893.     /* System generated locals */
  18894.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
  18895.     alist al__1, al__2;
  18896.  
  18897.     /* Builtin functions */
  18898.     integer f_rew(), f_back();
  18899.  
  18900.     /* Local variables */
  18901.     static doublecomplex temp;
  18902.     static integer i, j, k, i1, i2, k1, j2, ixblk1, ka, kk;
  18903.     extern /* Subroutine */ int blckin_(), blckot_();
  18904.     static integer nb1, nm1, ipi, ipk, ixt;
  18905.  
  18906. /* *** */
  18907.  
  18908. /*     S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX */
  18909.  
  18910. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  18911. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  18912. /*<       COMPLEX  A, TEMP >*/
  18913. /*<    >*/
  18914. /*<       DIMENSION  A( NROW,1), IP( NROW), IX( NROW) >*/
  18915. /*<       I1=1 >*/
  18916.     /* Parameter adjustments */
  18917.     --ip;
  18918.     --ix;
  18919.     a_dim1 = *nrow;
  18920.     a_offset = a_dim1 + 1;
  18921.     a -= a_offset;
  18922.  
  18923.     /* Function Body */
  18924.     i1 = 1;
  18925. /*<       I2=2* NPSYM* NROW >*/
  18926.     i2 = (matpar_1.npsym << 1) * *nrow;
  18927. /*<       NM1= NROW-1 >*/
  18928.     nm1 = *nrow - 1;
  18929. /*<       REWIND IU2 >*/
  18930.     al__1.aerr = 0;
  18931.     al__1.aunit = *iu2;
  18932.     f_rew(&al__1);
  18933. /*<       REWIND IU3 >*/
  18934.     al__1.aerr = 0;
  18935.     al__1.aunit = *iu3;
  18936.     f_rew(&al__1);
  18937. /*<       REWIND IU4 >*/
  18938.     al__1.aerr = 0;
  18939.     al__1.aunit = *iu4;
  18940.     f_rew(&al__1);
  18941. /*<       DO 9  KK=1, NOP >*/
  18942.     i__1 = *nop;
  18943.     for (kk = 1; kk <= i__1; ++kk) {
  18944. /*<       KA=( KK-1)* NROW >*/
  18945.     ka = (kk - 1) * *nrow;
  18946. /*<       DO 4  IXBLK1=1, NBLSYM >*/
  18947.     i__2 = matpar_1.nblsym;
  18948.     for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
  18949. /*<       CALL BLCKIN( A, IU2, I1, I2,1,121) >*/
  18950.         blckin_(&a[a_offset], iu2, &i1, &i2, &c__1, &c__121);
  18951. /*<       K1=( IXBLK1-1)* NPSYM+2 >*/
  18952.         k1 = (ixblk1 - 1) * matpar_1.npsym + 2;
  18953. /*<       IF( NM1.LT. K1) GOTO 3 >*/
  18954.         if (nm1 < k1) {
  18955.         goto L3;
  18956.         }
  18957. /*<       J2=0 >*/
  18958.         j2 = 0;
  18959. /*<       DO 2  K= K1, NM1 >*/
  18960.         i__3 = nm1;
  18961.         for (k = k1; k <= i__3; ++k) {
  18962. /*<       IF( J2.LT. NPSYM) J2= J2+1 >*/
  18963.         if (j2 < matpar_1.npsym) {
  18964.             ++j2;
  18965.         }
  18966. /*<       IPK= IP( K+ KA) >*/
  18967.         ipk = ip[k + ka];
  18968. /*<       DO 1  J=1, J2 >*/
  18969.         i__4 = j2;
  18970.         for (j = 1; j <= i__4; ++j) {
  18971. /*<       TEMP= A( K, J) >*/
  18972.             i__5 = k + j * a_dim1;
  18973.             temp.r = a[i__5].r, temp.i = a[i__5].i;
  18974. /*<       A( K, J)= A( IPK, J) >*/
  18975.             i__5 = k + j * a_dim1;
  18976.             i__6 = ipk + j * a_dim1;
  18977.             a[i__5].r = a[i__6].r, a[i__5].i = a[i__6].i;
  18978. /*<       A( IPK, J)= TEMP >*/
  18979.             i__5 = ipk + j * a_dim1;
  18980.             a[i__5].r = temp.r, a[i__5].i = temp.i;
  18981. /*<     1 CONTINUE >*/
  18982. /* L1: */
  18983.         }
  18984. /*<     2 CONTINUE >*/
  18985. /* L2: */
  18986.         }
  18987. /*<     3 CONTINUE >*/
  18988. L3:
  18989. /*<       CALL BLCKOT( A, IU3, I1, I2,1,122) >*/
  18990.         blckot_(&a[a_offset], iu3, &i1, &i2, &c__1, &c__122);
  18991. /*<     4 CONTINUE >*/
  18992. /* L4: */
  18993.     }
  18994. /*<       DO 5  IXBLK1=1, NBLSYM >*/
  18995.     i__2 = matpar_1.nblsym;
  18996.     for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
  18997. /*<       BACKSPACE IU3 >*/
  18998.         al__2.aerr = 0;
  18999.         al__2.aunit = *iu3;
  19000.         f_back(&al__2);
  19001. /*<       IF( IXBLK1.NE.1) BACKSPACE IU3 >*/
  19002.         if (ixblk1 != 1) {
  19003.         al__2.aerr = 0;
  19004.         al__2.aunit = *iu3;
  19005.         f_back(&al__2);
  19006.         }
  19007. /*<       CALL BLCKIN( A, IU3, I1, I2,1,123) >*/
  19008.         blckin_(&a[a_offset], iu3, &i1, &i2, &c__1, &c__123);
  19009. /*<       CALL BLCKOT( A, IU4, I1, I2,1,124) >*/
  19010.         blckot_(&a[a_offset], iu4, &i1, &i2, &c__1, &c__124);
  19011. /*<     5 CONTINUE >*/
  19012. /* L5: */
  19013.     }
  19014. /*<       DO 6  I=1, NROW >*/
  19015.     i__2 = *nrow;
  19016.     for (i = 1; i <= i__2; ++i) {
  19017. /*<       IX( I+ KA)= I >*/
  19018.         ix[i + ka] = i;
  19019. /*<     6 CONTINUE >*/
  19020. /* L6: */
  19021.     }
  19022. /*<       DO 7  I=1, NROW >*/
  19023.     i__2 = *nrow;
  19024.     for (i = 1; i <= i__2; ++i) {
  19025. /*<       IPI= IP( I+ KA) >*/
  19026.         ipi = ip[i + ka];
  19027. /*<       IXT= IX( I+ KA) >*/
  19028.         ixt = ix[i + ka];
  19029. /*<       IX( I+ KA)= IX( IPI+ KA) >*/
  19030.         ix[i + ka] = ix[ipi + ka];
  19031. /*<       IX( IPI+ KA)= IXT >*/
  19032.         ix[ipi + ka] = ixt;
  19033. /*<     7 CONTINUE >*/
  19034. /* L7: */
  19035.     }
  19036. /*<       IF( NOP.EQ.1) GOTO 9 >*/
  19037.     if (*nop == 1) {
  19038.         goto L9;
  19039.     }
  19040. /*     SKIP NB1 LOGICAL RECORDS FORWARD */
  19041. /*<       NB1= NBLSYM-1 >*/
  19042.     nb1 = matpar_1.nblsym - 1;
  19043. /*<       DO 8  IXBLK1=1, NB1 >*/
  19044.     i__2 = nb1;
  19045.     for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
  19046. /*<       CALL BLCKIN( A, IU3, I1, I2,1,125) >*/
  19047.         blckin_(&a[a_offset], iu3, &i1, &i2, &c__1, &c__125);
  19048. /*<     8 CONTINUE >*/
  19049. /* L8: */
  19050.     }
  19051. /*<     9 CONTINUE >*/
  19052. L9:
  19053.     ;
  19054.     }
  19055. /*<       REWIND IU2 >*/
  19056.     al__1.aerr = 0;
  19057.     al__1.aunit = *iu2;
  19058.     f_rew(&al__1);
  19059. /*<       REWIND IU3 >*/
  19060.     al__1.aerr = 0;
  19061.     al__1.aunit = *iu3;
  19062.     f_rew(&al__1);
  19063. /*<       REWIND IU4 >*/
  19064.     al__1.aerr = 0;
  19065.     al__1.aunit = *iu4;
  19066.     f_rew(&al__1);
  19067. /*<       RETURN >*/
  19068.     return 0;
  19069. /*<       END >*/
  19070. } /* lunscr_ */
  19071.  
  19072. /* *** */
  19073. /*     DOUBLE PRECISION 6/4/85 */
  19074.  
  19075. /*<       SUBROUTINE MOVE( ROX, ROY, ROZ, XS, YS, ZS, ITS, NRPT, ITGI) >*/
  19076. /* Subroutine */ int move_(rox, roy, roz, xs, ys, zs, its, nrpt, itgi)
  19077. doublereal *rox, *roy, *roz, *xs, *ys, *zs;
  19078. integer *its, *nrpt, *itgi;
  19079. {
  19080.     /* System generated locals */
  19081.     integer i__1, i__2;
  19082.     doublereal d__1, d__2;
  19083.  
  19084.     /* Builtin functions */
  19085.     double sin(), cos();
  19086.  
  19087.     /* Local variables */
  19088.     static integer i, k, i1;
  19089. #define x2 ((doublereal *)&data_1 + 1800)
  19090. #define y2 ((doublereal *)&data_1 + 3000)
  19091. #define z2 ((doublereal *)&data_1 + 3600)
  19092.     static integer ii, ir, kr, ix;
  19093.     static doublereal xi, yi, zi, xx, xy, xz, yx, yy, yz, zx, zy, zz;
  19094.     extern integer isegno_();
  19095. #define t1x ((doublereal *)&data_1 + 1800)
  19096. #define t1y ((doublereal *)&data_1 + 3000)
  19097. #define t1z ((doublereal *)&data_1 + 3600)
  19098. #define t2x ((doublereal *)&data_1 + 4201)
  19099. #define t2y ((doublereal *)&data_1 + 4601)
  19100. #define t2z ((doublereal *)&data_1 + 5001)
  19101.     static integer ldi;
  19102.     static doublereal cph, cth, cps, sph, sth;
  19103.     static integer nrp;
  19104.     static doublereal sps;
  19105.  
  19106. /* *** */
  19107.  
  19108. /*     SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS */
  19109. /*     COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS. */
  19110. /*     STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ */
  19111. /*     RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS */
  19112.  
  19113. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  19114. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  19115. /*<    >*/
  19116. /*<       COMMON  /ANGL/ SALP( NM) >*/
  19117. /*<    >*/
  19118. /*<       EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1)) >*/
  19119. /*<    >*/
  19120. /*<       IF( ABS( ROX)+ ABS( ROY).GT.1.D-10) IPSYM= IPSYM*3 >*/
  19121.     if (abs(*rox) + abs(*roy) > 1e-10) {
  19122.     data_1.ipsym *= 3;
  19123.     }
  19124. /*<       SPS= SIN( ROX) >*/
  19125.     sps = sin(*rox);
  19126. /*<       CPS= COS( ROX) >*/
  19127.     cps = cos(*rox);
  19128. /*<       STH= SIN( ROY) >*/
  19129.     sth = sin(*roy);
  19130. /*<       CTH= COS( ROY) >*/
  19131.     cth = cos(*roy);
  19132. /*<       SPH= SIN( ROZ) >*/
  19133.     sph = sin(*roz);
  19134. /*<       CPH= COS( ROZ) >*/
  19135.     cph = cos(*roz);
  19136. /*<       XX= CPH* CTH >*/
  19137.     xx = cph * cth;
  19138. /*<       XY= CPH* STH* SPS- SPH* CPS >*/
  19139.     d__1 = cph * sth;
  19140.     xy = d__1 * sps - sph * cps;
  19141. /*<       XZ= CPH* STH* CPS+ SPH* SPS >*/
  19142.     d__1 = cph * sth;
  19143.     xz = d__1 * cps + sph * sps;
  19144. /*<       YX= SPH* CTH >*/
  19145.     yx = sph * cth;
  19146. /*<       YY= SPH* STH* SPS+ CPH* CPS >*/
  19147.     d__1 = sph * sth;
  19148.     yy = d__1 * sps + cph * cps;
  19149. /*<       YZ= SPH* STH* CPS- CPH* SPS >*/
  19150.     d__1 = sph * sth;
  19151.     yz = d__1 * cps - cph * sps;
  19152. /*<       ZX=- STH >*/
  19153.     zx = -sth;
  19154. /*<       ZY= CTH* SPS >*/
  19155.     zy = cth * sps;
  19156. /*<       ZZ= CTH* CPS >*/
  19157.     zz = cth * cps;
  19158. /*<       NRP= NRPT >*/
  19159.     nrp = *nrpt;
  19160. /*<       IF( NRPT.EQ.0) NRP=1 >*/
  19161.     if (*nrpt == 0) {
  19162.     nrp = 1;
  19163.     }
  19164. /*<       IX=1 >*/
  19165.     ix = 1;
  19166. /*<       IF( N.LT. N2) GOTO 3 >*/
  19167.     if (data_1.n < data_1.n2) {
  19168.     goto L3;
  19169.     }
  19170. /*<       I1= ISEGNO( ITS,1) >*/
  19171.     i1 = isegno_(its, &c__1);
  19172. /*<       IF( I1.LT. N2) I1= N2 >*/
  19173.     if (i1 < data_1.n2) {
  19174.     i1 = data_1.n2;
  19175.     }
  19176. /*<       IX= I1 >*/
  19177.     ix = i1;
  19178. /*<       K= N >*/
  19179.     k = data_1.n;
  19180. /*<       IF( NRPT.EQ.0) K= I1-1 >*/
  19181.     if (*nrpt == 0) {
  19182.     k = i1 - 1;
  19183.     }
  19184. /*<       DO 2  IR=1, NRP >*/
  19185.     i__1 = nrp;
  19186.     for (ir = 1; ir <= i__1; ++ir) {
  19187. /*<       DO 1  I= I1, N >*/
  19188.     i__2 = data_1.n;
  19189.     for (i = i1; i <= i__2; ++i) {
  19190. /*<       K= K+1 >*/
  19191.         ++k;
  19192. /*<       XI= X( I) >*/
  19193.         xi = data_1.x[i - 1];
  19194. /*<       YI= Y( I) >*/
  19195.         yi = data_1.y[i - 1];
  19196. /*<       ZI= Z( I) >*/
  19197.         zi = data_1.z[i - 1];
  19198. /*<       X( K)= XI* XX+ YI* XY+ ZI* XZ+ XS >*/
  19199.         d__2 = xi * xx + yi * xy;
  19200.         d__1 = d__2 + zi * xz;
  19201.         data_1.x[k - 1] = d__1 + *xs;
  19202. /*<       Y( K)= XI* YX+ YI* YY+ ZI* YZ+ YS >*/
  19203.         d__2 = xi * yx + yi * yy;
  19204.         d__1 = d__2 + zi * yz;
  19205.         data_1.y[k - 1] = d__1 + *ys;
  19206. /*<       Z( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS >*/
  19207.         d__2 = xi * zx + yi * zy;
  19208.         d__1 = d__2 + zi * zz;
  19209.         data_1.z[k - 1] = d__1 + *zs;
  19210. /*<       XI= X2( I) >*/
  19211.         xi = x2[i - 1];
  19212. /*<       YI= Y2( I) >*/
  19213.         yi = y2[i - 1];
  19214. /*<       ZI= Z2( I) >*/
  19215.         zi = z2[i - 1];
  19216. /*<       X2( K)= XI* XX+ YI* XY+ ZI* XZ+ XS >*/
  19217.         d__2 = xi * xx + yi * xy;
  19218.         d__1 = d__2 + zi * xz;
  19219.         x2[k - 1] = d__1 + *xs;
  19220. /*<       Y2( K)= XI* YX+ YI* YY+ ZI* YZ+ YS >*/
  19221.         d__2 = xi * yx + yi * yy;
  19222.         d__1 = d__2 + zi * yz;
  19223.         y2[k - 1] = d__1 + *ys;
  19224. /*<       Z2( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS >*/
  19225.         d__2 = xi * zx + yi * zy;
  19226.         d__1 = d__2 + zi * zz;
  19227.         z2[k - 1] = d__1 + *zs;
  19228. /*<       BI( K)= BI( I) >*/
  19229.         data_1.bi[k - 1] = data_1.bi[i - 1];
  19230. /*<       ITAG( K)= ITAG( I) >*/
  19231.         data_1.itag[k - 1] = data_1.itag[i - 1];
  19232. /*<       IF( ITAG( I).NE.0) ITAG( K)= ITAG( I)+ ITGI >*/
  19233.         if (data_1.itag[i - 1] != 0) {
  19234.         data_1.itag[k - 1] = data_1.itag[i - 1] + *itgi;
  19235.         }
  19236. /*<     1 CONTINUE >*/
  19237. /* L1: */
  19238.     }
  19239. /*<       I1= N+1 >*/
  19240.     i1 = data_1.n + 1;
  19241. /*<       N= K >*/
  19242.     data_1.n = k;
  19243. /*<     2 CONTINUE >*/
  19244. /* L2: */
  19245.     }
  19246. /*<     3 IF( M.LT. M2) GOTO 6 >*/
  19247. L3:
  19248.     if (data_1.m < data_1.m2) {
  19249.     goto L6;
  19250.     }
  19251. /*<       I1= M2 >*/
  19252.     i1 = data_1.m2;
  19253. /*<       K= M >*/
  19254.     k = data_1.m;
  19255. /*<       LDI= LD+1 >*/
  19256.     ldi = data_1.ld + 1;
  19257. /*<       IF( NRPT.EQ.0) K= M1 >*/
  19258.     if (*nrpt == 0) {
  19259.     k = data_1.m1;
  19260.     }
  19261. /*<       DO 5  II=1, NRP >*/
  19262.     i__1 = nrp;
  19263.     for (ii = 1; ii <= i__1; ++ii) {
  19264. /*<       DO 4  I= I1, M >*/
  19265.     i__2 = data_1.m;
  19266.     for (i = i1; i <= i__2; ++i) {
  19267. /*<       K= K+1 >*/
  19268.         ++k;
  19269. /*<       IR= LDI- I >*/
  19270.         ir = ldi - i;
  19271. /*<       KR= LDI- K >*/
  19272.         kr = ldi - k;
  19273. /*<       XI= X( IR) >*/
  19274.         xi = data_1.x[ir - 1];
  19275. /*<       YI= Y( IR) >*/
  19276.         yi = data_1.y[ir - 1];
  19277. /*<       ZI= Z( IR) >*/
  19278.         zi = data_1.z[ir - 1];
  19279. /*<       X( KR)= XI* XX+ YI* XY+ ZI* XZ+ XS >*/
  19280.         d__2 = xi * xx + yi * xy;
  19281.         d__1 = d__2 + zi * xz;
  19282.         data_1.x[kr - 1] = d__1 + *xs;
  19283. /*<       Y( KR)= XI* YX+ YI* YY+ ZI* YZ+ YS >*/
  19284.         d__2 = xi * yx + yi * yy;
  19285.         d__1 = d__2 + zi * yz;
  19286.         data_1.y[kr - 1] = d__1 + *ys;
  19287. /*<       Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS >*/
  19288.         d__2 = xi * zx + yi * zy;
  19289.         d__1 = d__2 + zi * zz;
  19290.         data_1.z[kr - 1] = d__1 + *zs;
  19291. /*<       XI= T1X( IR) >*/
  19292.         xi = t1x[ir - 1];
  19293. /*<       YI= T1Y( IR) >*/
  19294.         yi = t1y[ir - 1];
  19295. /*<       ZI= T1Z( IR) >*/
  19296.         zi = t1z[ir - 1];
  19297. /*<       T1X( KR)= XI* XX+ YI* XY+ ZI* XZ >*/
  19298.         d__1 = xi * xx + yi * xy;
  19299.         t1x[kr - 1] = d__1 + zi * xz;
  19300. /*<       T1Y( KR)= XI* YX+ YI* YY+ ZI* YZ >*/
  19301.         d__1 = xi * yx + yi * yy;
  19302.         t1y[kr - 1] = d__1 + zi * yz;
  19303. /*<       T1Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ >*/
  19304.         d__1 = xi * zx + yi * zy;
  19305.         t1z[kr - 1] = d__1 + zi * zz;
  19306. /*<       XI= T2X( IR) >*/
  19307.         xi = t2x[ir - 1];
  19308. /*<       YI= T2Y( IR) >*/
  19309.         yi = t2y[ir - 1];
  19310. /*<       ZI= T2Z( IR) >*/
  19311.         zi = t2z[ir - 1];
  19312. /*<       T2X( KR)= XI* XX+ YI* XY+ ZI* XZ >*/
  19313.         d__1 = xi * xx + yi * xy;
  19314.         t2x[kr - 1] = d__1 + zi * xz;
  19315. /*<       T2Y( KR)= XI* YX+ YI* YY+ ZI* YZ >*/
  19316.         d__1 = xi * yx + yi * yy;
  19317.         t2y[kr - 1] = d__1 + zi * yz;
  19318. /*<       T2Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ >*/
  19319.         d__1 = xi * zx + yi * zy;
  19320.         t2z[kr - 1] = d__1 + zi * zz;
  19321. /*<       SALP( KR)= SALP( IR) >*/
  19322.         angl_1.salp[kr - 1] = angl_1.salp[ir - 1];
  19323. /*<     4 BI( KR)= BI( IR) >*/
  19324. /* L4: */
  19325.         data_1.bi[kr - 1] = data_1.bi[ir - 1];
  19326.     }
  19327. /*<       I1= M+1 >*/
  19328.     i1 = data_1.m + 1;
  19329. /*<     5 M= K >*/
  19330. /* L5: */
  19331.     data_1.m = k;
  19332.     }
  19333. /*<     6 IF(( NRPT.EQ.0).AND.( IX.EQ.1)) RETURN >*/
  19334. L6:
  19335.     if (*nrpt == 0 && ix == 1) {
  19336.     return 0;
  19337.     }
  19338. /*<       NP= N >*/
  19339.     data_1.np = data_1.n;
  19340. /*<       MP= M >*/
  19341.     data_1.mp = data_1.m;
  19342. /*<       IPSYM=0 >*/
  19343.     data_1.ipsym = 0;
  19344. /*<       RETURN >*/
  19345.     return 0;
  19346. /*<       END >*/
  19347. } /* move_ */
  19348.  
  19349. #undef t2z
  19350. #undef t2y
  19351. #undef t2x
  19352. #undef t1z
  19353. #undef t1y
  19354. #undef t1x
  19355. #undef z2
  19356. #undef y2
  19357. #undef x2
  19358.  
  19359.  
  19360. /* *** */
  19361. /*     DOUBLE PRECISION 6/4/85 */
  19362.  
  19363. /*<       SUBROUTINE NEFLD( XOB, YOB, ZOB, EX, EY, EZ) >*/
  19364. /* Subroutine */ int nefld_(xob, yob, zob, ex, ey, ez)
  19365. doublereal *xob, *yob, *zob;
  19366. doublecomplex *ex, *ey, *ez;
  19367. {
  19368.     /* System generated locals */
  19369.     integer i__1, i__2, i__3, i__4;
  19370.     doublereal d__1, d__2;
  19371.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
  19372.  
  19373.     /* Local variables */
  19374.     extern /* Subroutine */ int efld_();
  19375.     static integer i;
  19376.     extern /* Subroutine */ int unere_();
  19377.     static integer jc, jl;
  19378.     static doublereal ax;
  19379.     static integer ip;
  19380.     static doublereal xi, zp;
  19381. #define t1x ((doublereal *)&data_1 + 1800)
  19382. #define t1y ((doublereal *)&data_1 + 3000)
  19383. #define t1z ((doublereal *)&data_1 + 3600)
  19384. #define t2x ((doublereal *)&data_1 + 4201)
  19385. #define t2y ((doublereal *)&data_1 + 4601)
  19386. #define t2z ((doublereal *)&data_1 + 5001)
  19387. #define cab ((doublereal *)&data_1 + 3000)
  19388. #define sab ((doublereal *)&data_1 + 3600)
  19389.     static doublecomplex acx, bcx, ccx;
  19390.     static integer ipr;
  19391. #define t1xj ((doublereal *)&dataj_1 + 5)
  19392. #define t1yj ((doublereal *)&dataj_1 + 6)
  19393. #define t1zj ((doublereal *)&dataj_1 + 7)
  19394. #define t2xj ((doublereal *)&dataj_1 + 1)
  19395. #define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
  19396. #define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
  19397.  
  19398. /* *** */
  19399.  
  19400. /*     NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER */
  19401.  
  19402. /*     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED. */
  19403.  
  19404. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  19405. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  19406. /*<    >*/
  19407. /*<    >*/
  19408. /*<       COMMON  /ANGL/ SALP( NM) >*/
  19409. /*<    >*/
  19410. /*<    >*/
  19411. /*<    >*/
  19412. /*<    >*/
  19413. /*<       EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
  19414. /*<    >*/
  19415. /*<    >*/
  19416. /*<       EX=(0.,0.) >*/
  19417.     ex->r = 0., ex->i = 0.;
  19418. /*<       EY=(0.,0.) >*/
  19419.     ey->r = 0., ey->i = 0.;
  19420. /*<       EZ=(0.,0.) >*/
  19421.     ez->r = 0., ez->i = 0.;
  19422. /*<       AX=0. >*/
  19423.     ax = 0.;
  19424. /*<       IF( N.EQ.0) GOTO 20 >*/
  19425.     if (data_1.n == 0) {
  19426.     goto L20;
  19427.     }
  19428. /*<       DO 1  I=1, N >*/
  19429.     i__1 = data_1.n;
  19430.     for (i = 1; i <= i__1; ++i) {
  19431. /*<       XJ= XOB- X( I) >*/
  19432.     dataj_1.xj = *xob - data_1.x[i - 1];
  19433. /*<       YJ= YOB- Y( I) >*/
  19434.     dataj_1.yj = *yob - data_1.y[i - 1];
  19435. /*<       ZJ= ZOB- Z( I) >*/
  19436.     dataj_1.zj = *zob - data_1.z[i - 1];
  19437. /*<       ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ >*/
  19438.     d__1 = cab[i - 1] * dataj_1.xj + sab[i - 1] * dataj_1.yj;
  19439.     zp = d__1 + angl_1.salp[i - 1] * dataj_1.zj;
  19440. /*<       IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1 >*/
  19441.     if (abs(zp) > data_1.si[i - 1] * .5001) {
  19442.         goto L1;
  19443.     }
  19444. /*<       ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP >*/
  19445.     d__1 = dataj_1.xj * dataj_1.xj + dataj_1.yj * dataj_1.yj;
  19446.     zp = d__1 + dataj_1.zj * dataj_1.zj - zp * zp;
  19447. /*<       XJ= BI( I) >*/
  19448.     dataj_1.xj = data_1.bi[i - 1];
  19449. /*<       IF( ZP.GT.0.9* XJ* XJ) GOTO 1 >*/
  19450.     d__1 = dataj_1.xj * .9;
  19451.     if (zp > d__1 * dataj_1.xj) {
  19452.         goto L1;
  19453.     }
  19454. /*<       AX= XJ >*/
  19455.     ax = dataj_1.xj;
  19456. /*<       GOTO 2 >*/
  19457.     goto L2;
  19458. /*<     1 CONTINUE >*/
  19459. L1:
  19460.     ;
  19461.     }
  19462. /*<     2 DO 19  I=1, N >*/
  19463. L2:
  19464.     i__1 = data_1.n;
  19465.     for (i = 1; i <= i__1; ++i) {
  19466. /*<       S= SI( I) >*/
  19467.     dataj_1.s = data_1.si[i - 1];
  19468. /*<       B= BI( I) >*/
  19469.     dataj_1.b = data_1.bi[i - 1];
  19470. /*<       XJ= X( I) >*/
  19471.     dataj_1.xj = data_1.x[i - 1];
  19472. /*<       YJ= Y( I) >*/
  19473.     dataj_1.yj = data_1.y[i - 1];
  19474. /*<       ZJ= Z( I) >*/
  19475.     dataj_1.zj = data_1.z[i - 1];
  19476. /*<       CABJ= CAB( I) >*/
  19477.     dataj_1.cabj = cab[i - 1];
  19478. /*<       SABJ= SAB( I) >*/
  19479.     dataj_1.sabj = sab[i - 1];
  19480. /*<       SALPJ= SALP( I) >*/
  19481.     dataj_1.salpj = angl_1.salp[i - 1];
  19482. /*<       IF( IEXK.EQ.0) GOTO 18 >*/
  19483.     if (dataj_1.iexk == 0) {
  19484.         goto L18;
  19485.     }
  19486. /*<       IPR= ICON1( I) >*/
  19487.     ipr = data_1.icon1[i - 1];
  19488. /*<       IF( IPR) 3,8,4 >*/
  19489.     if (ipr < 0) {
  19490.         goto L3;
  19491.     } else if (ipr == 0) {
  19492.         goto L8;
  19493.     } else {
  19494.         goto L4;
  19495.     }
  19496. /*<     3 IPR=- IPR >*/
  19497. L3:
  19498.     ipr = -ipr;
  19499. /*<       IF(- ICON1( IPR).NE. I) GOTO 9 >*/
  19500.     if (-data_1.icon1[ipr - 1] != i) {
  19501.         goto L9;
  19502.     }
  19503. /*<       GOTO 6 >*/
  19504.     goto L6;
  19505. /*<     4 IF( IPR.NE. I) GOTO 5 >*/
  19506. L4:
  19507.     if (ipr != i) {
  19508.         goto L5;
  19509.     }
  19510. /*<       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 9 >*/
  19511.     if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) 
  19512.         {
  19513.         goto L9;
  19514.     }
  19515. /*<       GOTO 7 >*/
  19516.     goto L7;
  19517. /*<     5 IF( ICON2( IPR).NE. I) GOTO 9 >*/
  19518. L5:
  19519.     if (data_1.icon2[ipr - 1] != i) {
  19520.         goto L9;
  19521.     }
  19522. /*<     6 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
  19523. L6:
  19524.     d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
  19525.     xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
  19526. /*<       IF( XI.LT.0.999999D+0) GOTO 9 >*/
  19527.     if (xi < .999999) {
  19528.         goto L9;
  19529.     }
  19530. /*<       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 9 >*/
  19531.     if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
  19532.         goto L9;
  19533.     }
  19534. /*<     7 IND1=0 >*/
  19535. L7:
  19536.     dataj_1.ind1 = 0;
  19537. /*<       GOTO 10 >*/
  19538.     goto L10;
  19539. /*<     8 IND1=1 >*/
  19540. L8:
  19541.     dataj_1.ind1 = 1;
  19542. /*<       GOTO 10 >*/
  19543.     goto L10;
  19544. /*<     9 IND1=2 >*/
  19545. L9:
  19546.     dataj_1.ind1 = 2;
  19547. /*<    10 IPR= ICON2( I) >*/
  19548. L10:
  19549.     ipr = data_1.icon2[i - 1];
  19550. /*<       IF( IPR) 11,16,12 >*/
  19551.     if (ipr < 0) {
  19552.         goto L11;
  19553.     } else if (ipr == 0) {
  19554.         goto L16;
  19555.     } else {
  19556.         goto L12;
  19557.     }
  19558. /*<    11 IPR=- IPR >*/
  19559. L11:
  19560.     ipr = -ipr;
  19561. /*<       IF(- ICON2( IPR).NE. I) GOTO 17 >*/
  19562.     if (-data_1.icon2[ipr - 1] != i) {
  19563.         goto L17;
  19564.     }
  19565. /*<       GOTO 14 >*/
  19566.     goto L14;
  19567. /*<    12 IF( IPR.NE. I) GOTO 13 >*/
  19568. L12:
  19569.     if (ipr != i) {
  19570.         goto L13;
  19571.     }
  19572. /*<       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 17 >*/
  19573.     if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) 
  19574.         {
  19575.         goto L17;
  19576.     }
  19577. /*<       GOTO 15 >*/
  19578.     goto L15;
  19579. /*<    13 IF( ICON1( IPR).NE. I) GOTO 17 >*/
  19580. L13:
  19581.     if (data_1.icon1[ipr - 1] != i) {
  19582.         goto L17;
  19583.     }
  19584. /*<    14 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
  19585. L14:
  19586.     d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
  19587.     xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
  19588. /*<       IF( XI.LT.0.999999D+0) GOTO 17 >*/
  19589.     if (xi < .999999) {
  19590.         goto L17;
  19591.     }
  19592. /*<       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 17 >*/
  19593.     if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
  19594.         goto L17;
  19595.     }
  19596. /*<    15 IND2=0 >*/
  19597. L15:
  19598.     dataj_1.ind2 = 0;
  19599. /*<       GOTO 18 >*/
  19600.     goto L18;
  19601. /*<    16 IND2=1 >*/
  19602. L16:
  19603.     dataj_1.ind2 = 1;
  19604. /*<       GOTO 18 >*/
  19605.     goto L18;
  19606. /*<    17 IND2=2 >*/
  19607. L17:
  19608.     dataj_1.ind2 = 2;
  19609. /*<    18 CONTINUE >*/
  19610. L18:
  19611. /*<       CALL EFLD( XOB, YOB, ZOB, AX,1) >*/
  19612.     efld_(xob, yob, zob, &ax, &c__1);
  19613. /*<       ACX= CMPLX( AIR( I), AII( I)) >*/
  19614.     i__2 = i - 1;
  19615.     i__3 = i - 1;
  19616.     z__1.r = crnt_1.air[i__2], z__1.i = crnt_1.aii[i__3];
  19617.     acx.r = z__1.r, acx.i = z__1.i;
  19618. /*<       BCX= CMPLX( BIR( I), BII( I)) >*/
  19619.     i__2 = i - 1;
  19620.     i__3 = i - 1;
  19621.     z__1.r = crnt_1.bir[i__2], z__1.i = crnt_1.bii[i__3];
  19622.     bcx.r = z__1.r, bcx.i = z__1.i;
  19623. /*<       CCX= CMPLX( CIR( I), CII( I)) >*/
  19624.     i__2 = i - 1;
  19625.     i__3 = i - 1;
  19626.     z__1.r = crnt_1.cir[i__2], z__1.i = crnt_1.cii[i__3];
  19627.     ccx.r = z__1.r, ccx.i = z__1.i;
  19628. /*<       EX= EX+ EXK* ACX+ EXS* BCX+ EXC* CCX >*/
  19629.     z__4.r = dataj_1.exk.r * acx.r - dataj_1.exk.i * acx.i, z__4.i = 
  19630.         dataj_1.exk.r * acx.i + dataj_1.exk.i * acx.r;
  19631.     z__3.r = ex->r + z__4.r, z__3.i = ex->i + z__4.i;
  19632.     z__5.r = dataj_1.exs.r * bcx.r - dataj_1.exs.i * bcx.i, z__5.i = 
  19633.         dataj_1.exs.r * bcx.i + dataj_1.exs.i * bcx.r;
  19634.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  19635.     z__6.r = dataj_1.exc.r * ccx.r - dataj_1.exc.i * ccx.i, z__6.i = 
  19636.         dataj_1.exc.r * ccx.i + dataj_1.exc.i * ccx.r;
  19637.     z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  19638.     ex->r = z__1.r, ex->i = z__1.i;
  19639. /*<       EY= EY+ EYK* ACX+ EYS* BCX+ EYC* CCX >*/
  19640.     z__4.r = dataj_1.eyk.r * acx.r - dataj_1.eyk.i * acx.i, z__4.i = 
  19641.         dataj_1.eyk.r * acx.i + dataj_1.eyk.i * acx.r;
  19642.     z__3.r = ey->r + z__4.r, z__3.i = ey->i + z__4.i;
  19643.     z__5.r = dataj_1.eys.r * bcx.r - dataj_1.eys.i * bcx.i, z__5.i = 
  19644.         dataj_1.eys.r * bcx.i + dataj_1.eys.i * bcx.r;
  19645.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  19646.     z__6.r = dataj_1.eyc.r * ccx.r - dataj_1.eyc.i * ccx.i, z__6.i = 
  19647.         dataj_1.eyc.r * ccx.i + dataj_1.eyc.i * ccx.r;
  19648.     z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  19649.     ey->r = z__1.r, ey->i = z__1.i;
  19650. /*<    19 EZ= EZ+ EZK* ACX+ EZS* BCX+ EZC* CCX >*/
  19651. /* L19: */
  19652.     z__4.r = dataj_1.ezk.r * acx.r - dataj_1.ezk.i * acx.i, z__4.i = 
  19653.         dataj_1.ezk.r * acx.i + dataj_1.ezk.i * acx.r;
  19654.     z__3.r = ez->r + z__4.r, z__3.i = ez->i + z__4.i;
  19655.     z__5.r = dataj_1.ezs.r * bcx.r - dataj_1.ezs.i * bcx.i, z__5.i = 
  19656.         dataj_1.ezs.r * bcx.i + dataj_1.ezs.i * bcx.r;
  19657.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  19658.     z__6.r = dataj_1.ezc.r * ccx.r - dataj_1.ezc.i * ccx.i, z__6.i = 
  19659.         dataj_1.ezc.r * ccx.i + dataj_1.ezc.i * ccx.r;
  19660.     z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  19661.     ez->r = z__1.r, ez->i = z__1.i;
  19662.     }
  19663. /*<       IF( M.EQ.0) RETURN >*/
  19664.     if (data_1.m == 0) {
  19665.     return 0;
  19666.     }
  19667. /*<    20 JC= N >*/
  19668. L20:
  19669.     jc = data_1.n;
  19670. /*<       JL= LD+1 >*/
  19671.     jl = data_1.ld + 1;
  19672. /*<       DO 21  I=1, M >*/
  19673.     i__1 = data_1.m;
  19674.     for (i = 1; i <= i__1; ++i) {
  19675. /*<       JL= JL-1 >*/
  19676.     --jl;
  19677. /*<       S= BI( JL) >*/
  19678.     dataj_1.s = data_1.bi[jl - 1];
  19679. /*<       XJ= X( JL) >*/
  19680.     dataj_1.xj = data_1.x[jl - 1];
  19681. /*<       YJ= Y( JL) >*/
  19682.     dataj_1.yj = data_1.y[jl - 1];
  19683. /*<       ZJ= Z( JL) >*/
  19684.     dataj_1.zj = data_1.z[jl - 1];
  19685. /*<       T1XJ= T1X( JL) >*/
  19686.     *t1xj = t1x[jl - 1];
  19687. /*<       T1YJ= T1Y( JL) >*/
  19688.     *t1yj = t1y[jl - 1];
  19689. /*<       T1ZJ= T1Z( JL) >*/
  19690.     *t1zj = t1z[jl - 1];
  19691. /*<       T2XJ= T2X( JL) >*/
  19692.     *t2xj = t2x[jl - 1];
  19693. /*<       T2YJ= T2Y( JL) >*/
  19694.     *t2yj = t2y[jl - 1];
  19695. /*<       T2ZJ= T2Z( JL) >*/
  19696.     *t2zj = t2z[jl - 1];
  19697. /*<       JC= JC+3 >*/
  19698.     jc += 3;
  19699. /*<       ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC) >*/
  19700.     i__2 = jc - 3;
  19701.     z__3.r = *t1xj * crnt_1.cur[i__2].r, z__3.i = *t1xj * crnt_1.cur[i__2]
  19702.         .i;
  19703.     i__3 = jc - 2;
  19704.     z__4.r = *t1yj * crnt_1.cur[i__3].r, z__4.i = *t1yj * crnt_1.cur[i__3]
  19705.         .i;
  19706.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  19707.     i__4 = jc - 1;
  19708.     z__5.r = *t1zj * crnt_1.cur[i__4].r, z__5.i = *t1zj * crnt_1.cur[i__4]
  19709.         .i;
  19710.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  19711.     acx.r = z__1.r, acx.i = z__1.i;
  19712. /*<       BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC) >*/
  19713.     i__2 = jc - 3;
  19714.     z__3.r = *t2xj * crnt_1.cur[i__2].r, z__3.i = *t2xj * crnt_1.cur[i__2]
  19715.         .i;
  19716.     i__3 = jc - 2;
  19717.     z__4.r = *t2yj * crnt_1.cur[i__3].r, z__4.i = *t2yj * crnt_1.cur[i__3]
  19718.         .i;
  19719.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  19720.     i__4 = jc - 1;
  19721.     z__5.r = *t2zj * crnt_1.cur[i__4].r, z__5.i = *t2zj * crnt_1.cur[i__4]
  19722.         .i;
  19723.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  19724.     bcx.r = z__1.r, bcx.i = z__1.i;
  19725. /*<       DO 21  IP=1, KSYMP >*/
  19726.     i__2 = gnd_1.ksymp;
  19727.     for (ip = 1; ip <= i__2; ++ip) {
  19728. /*<       IPGND= IP >*/
  19729.         dataj_1.ipgnd = ip;
  19730. /*<       CALL UNERE( XOB, YOB, ZOB) >*/
  19731.         unere_(xob, yob, zob);
  19732. /*<       EX= EX+ ACX* EXK+ BCX* EXS >*/
  19733.         z__3.r = acx.r * dataj_1.exk.r - acx.i * dataj_1.exk.i, z__3.i = 
  19734.             acx.r * dataj_1.exk.i + acx.i * dataj_1.exk.r;
  19735.         z__2.r = ex->r + z__3.r, z__2.i = ex->i + z__3.i;
  19736.         z__4.r = bcx.r * dataj_1.exs.r - bcx.i * dataj_1.exs.i, z__4.i = 
  19737.             bcx.r * dataj_1.exs.i + bcx.i * dataj_1.exs.r;
  19738.         z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  19739.         ex->r = z__1.r, ex->i = z__1.i;
  19740. /*<       EY= EY+ ACX* EYK+ BCX* EYS >*/
  19741.         z__3.r = acx.r * dataj_1.eyk.r - acx.i * dataj_1.eyk.i, z__3.i = 
  19742.             acx.r * dataj_1.eyk.i + acx.i * dataj_1.eyk.r;
  19743.         z__2.r = ey->r + z__3.r, z__2.i = ey->i + z__3.i;
  19744.         z__4.r = bcx.r * dataj_1.eys.r - bcx.i * dataj_1.eys.i, z__4.i = 
  19745.             bcx.r * dataj_1.eys.i + bcx.i * dataj_1.eys.r;
  19746.         z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  19747.         ey->r = z__1.r, ey->i = z__1.i;
  19748. /*<    21 EZ= EZ+ ACX* EZK+ BCX* EZS >*/
  19749. /* L21: */
  19750.         z__3.r = acx.r * dataj_1.ezk.r - acx.i * dataj_1.ezk.i, z__3.i = 
  19751.             acx.r * dataj_1.ezk.i + acx.i * dataj_1.ezk.r;
  19752.         z__2.r = ez->r + z__3.r, z__2.i = ez->i + z__3.i;
  19753.         z__4.r = bcx.r * dataj_1.ezs.r - bcx.i * dataj_1.ezs.i, z__4.i = 
  19754.             bcx.r * dataj_1.ezs.i + bcx.i * dataj_1.ezs.r;
  19755.         z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  19756.         ez->r = z__1.r, ez->i = z__1.i;
  19757.     }
  19758.     }
  19759. /*<       RETURN >*/
  19760.     return 0;
  19761. /*<       END >*/
  19762. } /* nefld_ */
  19763.  
  19764. #undef t2zj
  19765. #undef t2yj
  19766. #undef t2xj
  19767. #undef t1zj
  19768. #undef t1yj
  19769. #undef t1xj
  19770. #undef sab
  19771. #undef cab
  19772. #undef t2z
  19773. #undef t2y
  19774. #undef t2x
  19775. #undef t1z
  19776. #undef t1y
  19777. #undef t1x
  19778.  
  19779.  
  19780. /* *** */
  19781. /*     DOUBLE PRECISION 6/4/85 */
  19782.  
  19783. /*<       SUBROUTINE NETWK( CM, CMB, CMC, CMD, IP, EINC)  >*/
  19784. /* Subroutine */ int netwk_(cm, cmb, cmc, cmd, ip, einc)
  19785. doublecomplex *cm, *cmb, *cmc, *cmd;
  19786. integer *ip;
  19787. doublecomplex *einc;
  19788. {
  19789.     /* Initialized data */
  19790.  
  19791.     static integer ndimn = 150;
  19792.     static integer ndimnp = 151;
  19793.     static doublereal tp = 6.283185308;
  19794.  
  19795.     /* Format strings */
  19796.     static char fmt_59[] = "(1x,\002ERROR - - NETWORK ARRAY DIMENSIONS TOO S\
  19797. MALL\002)";
  19798.     static char fmt_58[] = "(///,3x,\002MAXIMUM RELATIVE ASYMMETRY OF THE DR\
  19799. IVING POINT\002,\002 ADMITTANCE MATRIX IS\002,1p,e10.3,\002 FOR SEGMENTS\002\
  19800. ,i5,\002 AND\002,i5,/,3x,\002RMS RELATIVE ASYMMETRY IS\002,e10.3)";
  19801.     static char fmt_61[] = "(///,27x,\002- - - STRUCTURE EXCITATION DATA AT \
  19802. NETWORK CONN\002,\002ECTION POINTS - - -\002)";
  19803.     static char fmt_60[] = "(/,3x,\002TAG\002,3x,\002SEG.\002,4x,\002VOLTAGE\
  19804.  (VOLTS)\002,9x,\002CURRENT (\002,\002AMPS)\002,9x,\002IMPEDANCE (OHMS)\002,\
  19805. 8x,\002ADMITTANCE (MHOS)\002,6x,\002POWER\002,/,3x,\002NO.\002,3x,\002NO.\
  19806. \002,4x,\002REAL\002,8x,\002IMAG.\002,3(7x,\002REAL\002,8x,\002IMAG.\002),5x,\
  19807. \002(WATTS)\002)";
  19808.     static char fmt_62[] = "(2(1x,i5),1p,9e12.5)";
  19809.     static char fmt_63[] = "(///,42x,\002- - - ANTENNA INPUT PARAMETERS - \
  19810. - -\002)";
  19811.     static char fmt_64[] = "(1x,i5,\002 *\002,i4,1p,9e12.5)";
  19812.  
  19813.     /* System generated locals */
  19814.     integer i__1, i__2, i__3, i__4, i__5;
  19815.     doublereal d__1, d__2;
  19816.     doublecomplex z__1, z__2, z__3, z__4, z__5;
  19817.  
  19818.     /* Builtin functions */
  19819.     integer s_wsfe(), e_wsfe();
  19820.     /* Subroutine */ int s_stop();
  19821.     void z_div();
  19822.     double z_abs(), sqrt();
  19823.     integer do_fio();
  19824.     double sin(), cos();
  19825.     void d_cnjg();
  19826.  
  19827.     /* Local variables */
  19828.     static integer neqt, nteq, ipnt[150];
  19829.     static doublecomplex rhnt[150], vsrc[10], rhnx[150];
  19830.     static integer ntsc;
  19831.     static doublecomplex ymit;
  19832.     static integer nseg1, nseg2, neqz2, irow1, irow2, i, j;
  19833.     extern /* Subroutine */ int factr_();
  19834.     static integer nteqa[150], ntsca[150];
  19835.     extern /* Subroutine */ int solgf_(), solve_();
  19836.     static doublereal asa;
  19837.     static doublecomplex cmn[22500]    /* was [150][150] */;
  19838.     static doublereal asm_, y11i, y12i;
  19839.     static doublecomplex rhs[1000], cux;
  19840.     static integer nop;
  19841.     static doublereal y11r, y12r, y22r, y22i;
  19842.     static doublecomplex vlt;
  19843.     static doublereal pwr;
  19844.     static integer isc1, isc2;
  19845.     extern /* Subroutine */ int cabc_();
  19846.  
  19847.     /* Fortran I/O blocks */
  19848.     static cilist io___1546 = { 0, 6, 0, fmt_59, 0 };
  19849.     static cilist io___1555 = { 0, 6, 0, fmt_58, 0 };
  19850.     static cilist io___1569 = { 0, 6, 0, fmt_59, 0 };
  19851.     static cilist io___1571 = { 0, 6, 0, fmt_61, 0 };
  19852.     static cilist io___1572 = { 0, 6, 0, fmt_60, 0 };
  19853.     static cilist io___1575 = { 0, 6, 0, fmt_62, 0 };
  19854.     static cilist io___1576 = { 0, 6, 0, fmt_62, 0 };
  19855.     static cilist io___1577 = { 0, 6, 0, fmt_63, 0 };
  19856.     static cilist io___1578 = { 0, 6, 0, fmt_60, 0 };
  19857.     static cilist io___1579 = { 0, 6, 0, fmt_62, 0 };
  19858.     static cilist io___1580 = { 0, 6, 0, fmt_64, 0 };
  19859.  
  19860.  
  19861. /* *** */
  19862.  
  19863. /*     SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN */
  19864. /*     EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF */
  19865. /*     PRESENT. */
  19866.  
  19867. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  19868. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  19869. /*<    >*/
  19870. /*<    >*/
  19871. /*<    >*/
  19872. /*<    >*/
  19873. /*<    >*/
  19874. /*<       DIMENSION  EINC(1), IP(1), CM(1), CMB(1), CMC(1), CMD(1) >*/
  19875. /*<    >*/
  19876. /*<       DATA   NDIMN, NDIMNP/150,151/, TP/6.283185308D+0/ >*/
  19877.     /* Parameter adjustments */
  19878.     --einc;
  19879.     --ip;
  19880.     --cmd;
  19881.     --cmc;
  19882.     --cmb;
  19883.     --cm;
  19884.  
  19885.     /* Function Body */
  19886. /*<       NEQZ2= NEQ2 >*/
  19887.     neqz2 = netcx_1.neq2;
  19888. /*<       IF( NEQZ2.EQ.0) NEQZ2=1 >*/
  19889.     if (neqz2 == 0) {
  19890.     neqz2 = 1;
  19891.     }
  19892. /*<       PIN=0. >*/
  19893.     netcx_1.pin = 0.;
  19894. /*<       PNLS=0. >*/
  19895.     netcx_1.pnls = 0.;
  19896. /*<       NEQT= NEQ+ NEQ2 >*/
  19897.     neqt = netcx_1.neq + netcx_1.neq2;
  19898. /*<       IF( NTSOL.NE.0) GOTO 42 >*/
  19899.     if (netcx_1.ntsol != 0) {
  19900.     goto L42;
  19901.     }
  19902. /*<       NOP= NEQ/ NPEQ >*/
  19903.     nop = netcx_1.neq / netcx_1.npeq;
  19904.  
  19905. /*     COMPUTE RELATIVE MATRIX ASYMMETRY */
  19906.  
  19907. /*<       IF( MASYM.EQ.0) GOTO 14 >*/
  19908.     if (netcx_1.masym == 0) {
  19909.     goto L14;
  19910.     }
  19911. /*<       IROW1=0 >*/
  19912.     irow1 = 0;
  19913. /*<       IF( NONET.EQ.0) GOTO 5 >*/
  19914.     if (netcx_1.nonet == 0) {
  19915.     goto L5;
  19916.     }
  19917. /*<       DO 4  I=1, NONET >*/
  19918.     i__1 = netcx_1.nonet;
  19919.     for (i = 1; i <= i__1; ++i) {
  19920. /*<       NSEG1= ISEG1( I) >*/
  19921.     nseg1 = netcx_1.iseg1[i - 1];
  19922. /*<       DO 3  ISC1=1,2 >*/
  19923.     for (isc1 = 1; isc1 <= 2; ++isc1) {
  19924. /*<       IF( IROW1.EQ.0) GOTO 2 >*/
  19925.         if (irow1 == 0) {
  19926.         goto L2;
  19927.         }
  19928. /*<       DO 1  J=1, IROW1 >*/
  19929.         i__2 = irow1;
  19930.         for (j = 1; j <= i__2; ++j) {
  19931. /*<       IF( NSEG1.EQ. IPNT( J)) GOTO 3 >*/
  19932.         if (nseg1 == ipnt[j - 1]) {
  19933.             goto L3;
  19934.         }
  19935. /*<     1 CONTINUE >*/
  19936. /* L1: */
  19937.         }
  19938. /*<     2 IROW1= IROW1+1 >*/
  19939. L2:
  19940.         ++irow1;
  19941. /*<       IPNT( IROW1)= NSEG1 >*/
  19942.         ipnt[irow1 - 1] = nseg1;
  19943. /*<     3 NSEG1= ISEG2( I) >*/
  19944. L3:
  19945.         nseg1 = netcx_1.iseg2[i - 1];
  19946.     }
  19947. /*<     4 CONTINUE >*/
  19948. /* L4: */
  19949.     }
  19950. /*<     5 IF( NSANT.EQ.0) GOTO 9 >*/
  19951. L5:
  19952.     if (vsorc_1.nsant == 0) {
  19953.     goto L9;
  19954.     }
  19955. /*<       DO 8  I=1, NSANT >*/
  19956.     i__1 = vsorc_1.nsant;
  19957.     for (i = 1; i <= i__1; ++i) {
  19958. /*<       NSEG1= ISANT( I) >*/
  19959.     nseg1 = vsorc_1.isant[i - 1];
  19960. /*<       IF( IROW1.EQ.0) GOTO 7 >*/
  19961.     if (irow1 == 0) {
  19962.         goto L7;
  19963.     }
  19964. /*<       DO 6  J=1, IROW1 >*/
  19965.     i__2 = irow1;
  19966.     for (j = 1; j <= i__2; ++j) {
  19967. /*<       IF( NSEG1.EQ. IPNT( J)) GOTO 8 >*/
  19968.         if (nseg1 == ipnt[j - 1]) {
  19969.         goto L8;
  19970.         }
  19971. /*<     6 CONTINUE >*/
  19972. /* L6: */
  19973.     }
  19974. /*<     7 IROW1= IROW1+1 >*/
  19975. L7:
  19976.     ++irow1;
  19977. /*<       IPNT( IROW1)= NSEG1 >*/
  19978.     ipnt[irow1 - 1] = nseg1;
  19979. /*<     8 CONTINUE >*/
  19980. L8:
  19981.     ;
  19982.     }
  19983. /*<     9 IF( IROW1.LT. NDIMNP) GOTO 10 >*/
  19984. L9:
  19985.     if (irow1 < ndimnp) {
  19986.     goto L10;
  19987.     }
  19988. /*<       WRITE( 6,59)  >*/
  19989.     s_wsfe(&io___1546);
  19990.     e_wsfe();
  19991. /*<       STOP >*/
  19992.     s_stop("", 0L);
  19993. /*<    10 IF( IROW1.LT.2) GOTO 14 >*/
  19994. L10:
  19995.     if (irow1 < 2) {
  19996.     goto L14;
  19997.     }
  19998. /*<       DO 12  I=1, IROW1 >*/
  19999.     i__1 = irow1;
  20000.     for (i = 1; i <= i__1; ++i) {
  20001. /*<       ISC1= IPNT( I) >*/
  20002.     isc1 = ipnt[i - 1];
  20003. /*<       ASM= SI( ISC1) >*/
  20004.     asm_ = data_1.si[isc1 - 1];
  20005. /*<       DO 11  J=1, NEQT >*/
  20006.     i__2 = neqt;
  20007.     for (j = 1; j <= i__2; ++j) {
  20008. /*<    11 RHS( J)=(0.,0.) >*/
  20009. /* L11: */
  20010.         i__3 = j - 1;
  20011.         rhs[i__3].r = 0., rhs[i__3].i = 0.;
  20012.     }
  20013. /*<       RHS( ISC1)=(1.,0.) >*/
  20014.     i__3 = isc1 - 1;
  20015.     rhs[i__3].r = 1., rhs[i__3].i = 0.;
  20016. /*<    >*/
  20017.     solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], rhs, &ip[1], &data_1.np, &
  20018.         data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
  20019.         netcx_1.neq, &netcx_1.neq2, &neqz2);
  20020. /*<       CALL CABC( RHS) >*/
  20021.     cabc_(rhs);
  20022. /*<       DO 12  J=1, IROW1 >*/
  20023.     i__3 = irow1;
  20024.     for (j = 1; j <= i__3; ++j) {
  20025. /*<       ISC1= IPNT( J) >*/
  20026.         isc1 = ipnt[j - 1];
  20027. /*<    12 CMN( J, I)= RHS( ISC1)/ ASM >*/
  20028. /* L12: */
  20029.         i__2 = j + i * 150 - 151;
  20030.         i__4 = isc1 - 1;
  20031.         z__1.r = rhs[i__4].r / asm_, z__1.i = rhs[i__4].i / asm_;
  20032.         cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
  20033.     }
  20034.     }
  20035. /*<       ASM=0. >*/
  20036.     asm_ = 0.;
  20037. /*<       ASA=0. >*/
  20038.     asa = 0.;
  20039. /*<       DO 13  I=2, IROW1 >*/
  20040.     i__2 = irow1;
  20041.     for (i = 2; i <= i__2; ++i) {
  20042. /*<       ISC1= I-1 >*/
  20043.     isc1 = i - 1;
  20044. /*<       DO 13  J=1, ISC1 >*/
  20045.     i__4 = isc1;
  20046.     for (j = 1; j <= i__4; ++j) {
  20047. /*<       CUX= CMN( I, J) >*/
  20048.         i__3 = i + j * 150 - 151;
  20049.         cux.r = cmn[i__3].r, cux.i = cmn[i__3].i;
  20050. /*<       PWR= ABS(( CUX- CMN( J, I))/ CUX) >*/
  20051.         i__3 = j + i * 150 - 151;
  20052.         z__2.r = cux.r - cmn[i__3].r, z__2.i = cux.i - cmn[i__3].i;
  20053.         z_div(&z__1, &z__2, &cux);
  20054.         pwr = z_abs(&z__1);
  20055. /*<       ASA= ASA+ PWR* PWR >*/
  20056.         asa += pwr * pwr;
  20057. /*<       IF( PWR.LT. ASM) GOTO 13 >*/
  20058.         if (pwr < asm_) {
  20059.         goto L13;
  20060.         }
  20061. /*<       ASM= PWR >*/
  20062.         asm_ = pwr;
  20063. /*<       NTEQ= IPNT( I) >*/
  20064.         nteq = ipnt[i - 1];
  20065. /*<       NTSC= IPNT( J) >*/
  20066.         ntsc = ipnt[j - 1];
  20067. /*<    13 CONTINUE >*/
  20068. L13:
  20069.         ;
  20070.     }
  20071.     }
  20072. /*<       ASA= SQRT( ASA*2./ DFLOAT( IROW1*( IROW1-1))) >*/
  20073.     asa = sqrt(asa * 2. / (doublereal) (irow1 * (irow1 - 1)));
  20074. /*<       WRITE( 6,58)  ASM, NTEQ, NTSC, ASA >*/
  20075.     s_wsfe(&io___1555);
  20076.     do_fio(&c__1, (char *)&asm_, (ftnlen)sizeof(doublereal));
  20077.     do_fio(&c__1, (char *)&nteq, (ftnlen)sizeof(integer));
  20078.     do_fio(&c__1, (char *)&ntsc, (ftnlen)sizeof(integer));
  20079.     do_fio(&c__1, (char *)&asa, (ftnlen)sizeof(doublereal));
  20080.     e_wsfe();
  20081.  
  20082. /*     SOLUTION OF NETWORK EQUATIONS */
  20083.  
  20084. /*<    14 IF( NONET.EQ.0) GOTO 48 >*/
  20085. L14:
  20086.     if (netcx_1.nonet == 0) {
  20087.     goto L48;
  20088.     }
  20089. /*<       DO 15  I=1, NDIMN >*/
  20090.     i__4 = ndimn;
  20091.     for (i = 1; i <= i__4; ++i) {
  20092. /*<       RHNX( I)=(0.,0.) >*/
  20093.     i__2 = i - 1;
  20094.     rhnx[i__2].r = 0., rhnx[i__2].i = 0.;
  20095. /*<       DO 15  J=1, NDIMN >*/
  20096.     i__2 = ndimn;
  20097.     for (j = 1; j <= i__2; ++j) {
  20098. /*<    15 CMN( I, J)=(0.,0.) >*/
  20099. /* L15: */
  20100.         i__3 = i + j * 150 - 151;
  20101.         cmn[i__3].r = 0., cmn[i__3].i = 0.;
  20102.     }
  20103.     }
  20104. /*<       NTEQ=0 >*/
  20105.     nteq = 0;
  20106.  
  20107. /*     SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO */
  20108. /*     SEGMENTS. */
  20109.  
  20110. /*<       NTSC=0 >*/
  20111.     ntsc = 0;
  20112. /*<       DO 38  J=1, NONET >*/
  20113.     i__3 = netcx_1.nonet;
  20114.     for (j = 1; j <= i__3; ++j) {
  20115. /*<       NSEG1= ISEG1( J) >*/
  20116.     nseg1 = netcx_1.iseg1[j - 1];
  20117. /*<       NSEG2= ISEG2( J) >*/
  20118.     nseg2 = netcx_1.iseg2[j - 1];
  20119. /*<       IF( NTYP( J).GT.1) GOTO 16 >*/
  20120.     if (netcx_1.ntyp[j - 1] > 1) {
  20121.         goto L16;
  20122.     }
  20123. /*<       Y11R= X11R( J) >*/
  20124.     y11r = netcx_1.x11r[j - 1];
  20125. /*<       Y11I= X11I( J) >*/
  20126.     y11i = netcx_1.x11i[j - 1];
  20127. /*<       Y12R= X12R( J) >*/
  20128.     y12r = netcx_1.x12r[j - 1];
  20129. /*<       Y12I= X12I( J) >*/
  20130.     y12i = netcx_1.x12i[j - 1];
  20131. /*<       Y22R= X22R( J) >*/
  20132.     y22r = netcx_1.x22r[j - 1];
  20133. /*<       Y22I= X22I( J) >*/
  20134.     y22i = netcx_1.x22i[j - 1];
  20135. /*<       GOTO 17 >*/
  20136.     goto L17;
  20137. /*<    16 Y22R= TP* X11I( J)/ WLAM >*/
  20138. L16:
  20139.     y22r = tp * netcx_1.x11i[j - 1] / data_1.wlam;
  20140. /*<       Y12R=0. >*/
  20141.     y12r = 0.;
  20142. /*<       Y12I=1./( X11R( J)* SIN( Y22R)) >*/
  20143.     y12i = 1. / (netcx_1.x11r[j - 1] * sin(y22r));
  20144. /*<       Y11R= X12R( J) >*/
  20145.     y11r = netcx_1.x12r[j - 1];
  20146. /*<       Y11I=- Y12I* COS( Y22R) >*/
  20147.     y11i = -y12i * cos(y22r);
  20148. /*<       Y22R= X22R( J) >*/
  20149.     y22r = netcx_1.x22r[j - 1];
  20150. /*<       Y22I= Y11I+ X22I( J) >*/
  20151.     y22i = y11i + netcx_1.x22i[j - 1];
  20152. /*<       Y11I= Y11I+ X12I( J) >*/
  20153.     y11i += netcx_1.x12i[j - 1];
  20154. /*<       IF( NTYP( J).EQ.2) GOTO 17 >*/
  20155.     if (netcx_1.ntyp[j - 1] == 2) {
  20156.         goto L17;
  20157.     }
  20158. /*<       Y12R=- Y12R >*/
  20159.     y12r = -y12r;
  20160. /*<       Y12I=- Y12I >*/
  20161.     y12i = -y12i;
  20162. /*<    17 IF( NSANT.EQ.0) GOTO 19 >*/
  20163. L17:
  20164.     if (vsorc_1.nsant == 0) {
  20165.         goto L19;
  20166.     }
  20167. /*<       DO 18  I=1, NSANT >*/
  20168.     i__2 = vsorc_1.nsant;
  20169.     for (i = 1; i <= i__2; ++i) {
  20170. /*<       IF( NSEG1.NE. ISANT( I)) GOTO 18 >*/
  20171.         if (nseg1 != vsorc_1.isant[i - 1]) {
  20172.         goto L18;
  20173.         }
  20174. /*<       ISC1= I >*/
  20175.         isc1 = i;
  20176. /*<       GOTO 22 >*/
  20177.         goto L22;
  20178. /*<    18 CONTINUE >*/
  20179. L18:
  20180.         ;
  20181.     }
  20182. /*<    19 ISC1=0 >*/
  20183. L19:
  20184.     isc1 = 0;
  20185. /*<       IF( NTEQ.EQ.0) GOTO 21 >*/
  20186.     if (nteq == 0) {
  20187.         goto L21;
  20188.     }
  20189. /*<       DO 20  I=1, NTEQ >*/
  20190.     i__2 = nteq;
  20191.     for (i = 1; i <= i__2; ++i) {
  20192. /*<       IF( NSEG1.NE. NTEQA( I)) GOTO 20 >*/
  20193.         if (nseg1 != nteqa[i - 1]) {
  20194.         goto L20;
  20195.         }
  20196. /*<       IROW1= I >*/
  20197.         irow1 = i;
  20198. /*<       GOTO 25 >*/
  20199.         goto L25;
  20200. /*<    20 CONTINUE >*/
  20201. L20:
  20202.         ;
  20203.     }
  20204. /*<    21 NTEQ= NTEQ+1 >*/
  20205. L21:
  20206.     ++nteq;
  20207. /*<       IROW1= NTEQ >*/
  20208.     irow1 = nteq;
  20209. /*<       NTEQA( NTEQ)= NSEG1 >*/
  20210.     nteqa[nteq - 1] = nseg1;
  20211. /*<       GOTO 25 >*/
  20212.     goto L25;
  20213. /*<    22 IF( NTSC.EQ.0) GOTO 24 >*/
  20214. L22:
  20215.     if (ntsc == 0) {
  20216.         goto L24;
  20217.     }
  20218. /*<       DO 23  I=1, NTSC >*/
  20219.     i__2 = ntsc;
  20220.     for (i = 1; i <= i__2; ++i) {
  20221. /*<       IF( NSEG1.NE. NTSCA( I)) GOTO 23 >*/
  20222.         if (nseg1 != ntsca[i - 1]) {
  20223.         goto L23;
  20224.         }
  20225. /*<       IROW1= NDIMNP- I >*/
  20226.         irow1 = ndimnp - i;
  20227. /*<       GOTO 25 >*/
  20228.         goto L25;
  20229. /*<    23 CONTINUE >*/
  20230. L23:
  20231.         ;
  20232.     }
  20233. /*<    24 NTSC= NTSC+1 >*/
  20234. L24:
  20235.     ++ntsc;
  20236. /*<       IROW1= NDIMNP- NTSC >*/
  20237.     irow1 = ndimnp - ntsc;
  20238. /*<       NTSCA( NTSC)= NSEG1 >*/
  20239.     ntsca[ntsc - 1] = nseg1;
  20240. /*<       VSRC( NTSC)= VSANT( ISC1) >*/
  20241.     i__2 = ntsc - 1;
  20242.     i__4 = isc1 - 1;
  20243.     vsrc[i__2].r = vsorc_1.vsant[i__4].r, vsrc[i__2].i = vsorc_1.vsant[
  20244.         i__4].i;
  20245. /*<    25 IF( NSANT.EQ.0) GOTO 27 >*/
  20246. L25:
  20247.     if (vsorc_1.nsant == 0) {
  20248.         goto L27;
  20249.     }
  20250. /*<       DO 26  I=1, NSANT >*/
  20251.     i__2 = vsorc_1.nsant;
  20252.     for (i = 1; i <= i__2; ++i) {
  20253. /*<       IF( NSEG2.NE. ISANT( I)) GOTO 26 >*/
  20254.         if (nseg2 != vsorc_1.isant[i - 1]) {
  20255.         goto L26;
  20256.         }
  20257. /*<       ISC2= I >*/
  20258.         isc2 = i;
  20259. /*<       GOTO 30 >*/
  20260.         goto L30;
  20261. /*<    26 CONTINUE >*/
  20262. L26:
  20263.         ;
  20264.     }
  20265. /*<    27 ISC2=0 >*/
  20266. L27:
  20267.     isc2 = 0;
  20268. /*<       IF( NTEQ.EQ.0) GOTO 29 >*/
  20269.     if (nteq == 0) {
  20270.         goto L29;
  20271.     }
  20272. /*<       DO 28  I=1, NTEQ >*/
  20273.     i__2 = nteq;
  20274.     for (i = 1; i <= i__2; ++i) {
  20275. /*<       IF( NSEG2.NE. NTEQA( I)) GOTO 28 >*/
  20276.         if (nseg2 != nteqa[i - 1]) {
  20277.         goto L28;
  20278.         }
  20279. /*<       IROW2= I >*/
  20280.         irow2 = i;
  20281. /*<       GOTO 33 >*/
  20282.         goto L33;
  20283. /*<    28 CONTINUE >*/
  20284. L28:
  20285.         ;
  20286.     }
  20287. /*<    29 NTEQ= NTEQ+1 >*/
  20288. L29:
  20289.     ++nteq;
  20290. /*<       IROW2= NTEQ >*/
  20291.     irow2 = nteq;
  20292. /*<       NTEQA( NTEQ)= NSEG2 >*/
  20293.     nteqa[nteq - 1] = nseg2;
  20294. /*<       GOTO 33 >*/
  20295.     goto L33;
  20296. /*<    30 IF( NTSC.EQ.0) GOTO 32 >*/
  20297. L30:
  20298.     if (ntsc == 0) {
  20299.         goto L32;
  20300.     }
  20301. /*<       DO 31  I=1, NTSC >*/
  20302.     i__2 = ntsc;
  20303.     for (i = 1; i <= i__2; ++i) {
  20304. /*<       IF( NSEG2.NE. NTSCA( I)) GOTO 31 >*/
  20305.         if (nseg2 != ntsca[i - 1]) {
  20306.         goto L31;
  20307.         }
  20308. /*<       IROW2= NDIMNP- I >*/
  20309.         irow2 = ndimnp - i;
  20310. /*<       GOTO 33 >*/
  20311.         goto L33;
  20312. /*<    31 CONTINUE >*/
  20313. L31:
  20314.         ;
  20315.     }
  20316. /*<    32 NTSC= NTSC+1 >*/
  20317. L32:
  20318.     ++ntsc;
  20319. /*<       IROW2= NDIMNP- NTSC >*/
  20320.     irow2 = ndimnp - ntsc;
  20321. /*<       NTSCA( NTSC)= NSEG2 >*/
  20322.     ntsca[ntsc - 1] = nseg2;
  20323. /*<       VSRC( NTSC)= VSANT( ISC2) >*/
  20324.     i__2 = ntsc - 1;
  20325.     i__4 = isc2 - 1;
  20326.     vsrc[i__2].r = vsorc_1.vsant[i__4].r, vsrc[i__2].i = vsorc_1.vsant[
  20327.         i__4].i;
  20328. /*<    33 IF( NTSC+ NTEQ.LT. NDIMNP) GOTO 34 >*/
  20329. L33:
  20330.     if (ntsc + nteq < ndimnp) {
  20331.         goto L34;
  20332.     }
  20333. /*<       WRITE( 6,59)  >*/
  20334.     s_wsfe(&io___1569);
  20335.     e_wsfe();
  20336.  
  20337. /*     FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH */
  20338.  
  20339. /*     NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS. */
  20340.  
  20341. /*<       STOP >*/
  20342.     s_stop("", 0L);
  20343. /*<    34 IF( ISC1.NE.0) GOTO 35 >*/
  20344. L34:
  20345.     if (isc1 != 0) {
  20346.         goto L35;
  20347.     }
  20348. /*<    >*/
  20349.     i__2 = irow1 + irow1 * 150 - 151;
  20350.     i__4 = irow1 + irow1 * 150 - 151;
  20351.     z__3.r = y11r, z__3.i = y11i;
  20352.     i__1 = nseg1 - 1;
  20353.     z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
  20354.     z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
  20355.     cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
  20356. /*<    >*/
  20357.     i__2 = irow1 + irow2 * 150 - 151;
  20358.     i__4 = irow1 + irow2 * 150 - 151;
  20359.     z__3.r = y12r, z__3.i = y12i;
  20360.     i__1 = nseg1 - 1;
  20361.     z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
  20362.     z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
  20363.     cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
  20364. /*<       GOTO 36 >*/
  20365.     goto L36;
  20366. /*<    >*/
  20367. L35:
  20368.     i__2 = irow1 - 1;
  20369.     i__4 = irow1 - 1;
  20370.     z__4.r = y11r, z__4.i = y11i;
  20371.     i__1 = isc1 - 1;
  20372.     z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
  20373.         .i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i * 
  20374.         vsorc_1.vsant[i__1].r;
  20375.     z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
  20376.     z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
  20377.     rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
  20378. /*<    >*/
  20379.     i__2 = irow2 - 1;
  20380.     i__4 = irow2 - 1;
  20381.     z__4.r = y12r, z__4.i = y12i;
  20382.     i__1 = isc1 - 1;
  20383.     z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
  20384.         .i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i * 
  20385.         vsorc_1.vsant[i__1].r;
  20386.     z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
  20387.     z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
  20388.     rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
  20389. /*<    36 IF( ISC2.NE.0) GOTO 37 >*/
  20390. L36:
  20391.     if (isc2 != 0) {
  20392.         goto L37;
  20393.     }
  20394. /*<    >*/
  20395.     i__2 = irow2 + irow2 * 150 - 151;
  20396.     i__4 = irow2 + irow2 * 150 - 151;
  20397.     z__3.r = y22r, z__3.i = y22i;
  20398.     i__1 = nseg2 - 1;
  20399.     z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
  20400.     z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
  20401.     cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
  20402. /*<    >*/
  20403.     i__2 = irow2 + irow1 * 150 - 151;
  20404.     i__4 = irow2 + irow1 * 150 - 151;
  20405.     z__3.r = y12r, z__3.i = y12i;
  20406.     i__1 = nseg2 - 1;
  20407.     z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
  20408.     z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
  20409.     cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
  20410. /*<       GOTO 38 >*/
  20411.     goto L38;
  20412. /*<    >*/
  20413. L37:
  20414.     i__2 = irow1 - 1;
  20415.     i__4 = irow1 - 1;
  20416.     z__4.r = y12r, z__4.i = y12i;
  20417.     i__1 = isc2 - 1;
  20418.     z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
  20419.         .i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i * 
  20420.         vsorc_1.vsant[i__1].r;
  20421.     z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
  20422.     z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
  20423.     rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
  20424. /*<    >*/
  20425.     i__2 = irow2 - 1;
  20426.     i__4 = irow2 - 1;
  20427.     z__4.r = y22r, z__4.i = y22i;
  20428.     i__1 = isc2 - 1;
  20429.     z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
  20430.         .i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i * 
  20431.         vsorc_1.vsant[i__1].r;
  20432.     z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
  20433.     z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
  20434.     rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
  20435.  
  20436. /*     ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION 
  20437. */
  20438. /*     MATRIX */
  20439.  
  20440. /*<    38 CONTINUE >*/
  20441. L38:
  20442.     ;
  20443.     }
  20444. /*<       DO 41  I=1, NTEQ >*/
  20445.     i__3 = nteq;
  20446.     for (i = 1; i <= i__3; ++i) {
  20447. /*<       DO 39  J=1, NEQT >*/
  20448.     i__2 = neqt;
  20449.     for (j = 1; j <= i__2; ++j) {
  20450. /*<    39 RHS( J)=(0.,0.) >*/
  20451. /* L39: */
  20452.         i__4 = j - 1;
  20453.         rhs[i__4].r = 0., rhs[i__4].i = 0.;
  20454.     }
  20455. /*<       IROW1= NTEQA( I) >*/
  20456.     irow1 = nteqa[i - 1];
  20457. /*<       RHS( IROW1)=(1.,0.) >*/
  20458.     i__4 = irow1 - 1;
  20459.     rhs[i__4].r = 1., rhs[i__4].i = 0.;
  20460. /*<    >*/
  20461.     solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], rhs, &ip[1], &data_1.np, &
  20462.         data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
  20463.         netcx_1.neq, &netcx_1.neq2, &neqz2);
  20464. /*<       CALL CABC( RHS) >*/
  20465.     cabc_(rhs);
  20466. /*<       DO 40  J=1, NTEQ >*/
  20467.     i__4 = nteq;
  20468.     for (j = 1; j <= i__4; ++j) {
  20469. /*<       IROW1= NTEQA( J) >*/
  20470.         irow1 = nteqa[j - 1];
  20471. /*<    40 CMN( I, J)= CMN( I, J)+ RHS( IROW1) >*/
  20472. /* L40: */
  20473.         i__2 = i + j * 150 - 151;
  20474.         i__1 = i + j * 150 - 151;
  20475.         i__5 = irow1 - 1;
  20476.         z__1.r = cmn[i__1].r + rhs[i__5].r, z__1.i = cmn[i__1].i + rhs[
  20477.             i__5].i;
  20478.         cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
  20479.     }
  20480.  
  20481. /*     FACTOR NETWORK EQUATION MATRIX */
  20482.  
  20483. /*<    41 CONTINUE >*/
  20484. /* L41: */
  20485.     }
  20486.  
  20487. /*     ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT */
  20488.  
  20489. /*     INTERACTIONS */
  20490.  
  20491. /*<       CALL FACTR( NTEQ, CMN, IPNT, NDIMN) >*/
  20492.     factr_(&nteq, cmn, ipnt, &ndimn);
  20493. /*<    42 IF( NONET.EQ.0) GOTO 48 >*/
  20494. L42:
  20495.     if (netcx_1.nonet == 0) {
  20496.     goto L48;
  20497.     }
  20498. /*<       DO 43  I=1, NEQT >*/
  20499.     i__3 = neqt;
  20500.     for (i = 1; i <= i__3; ++i) {
  20501. /*<    43 RHS( I)= EINC( I) >*/
  20502. /* L43: */
  20503.     i__2 = i - 1;
  20504.     i__1 = i;
  20505.     rhs[i__2].r = einc[i__1].r, rhs[i__2].i = einc[i__1].i;
  20506.     }
  20507. /*<    >*/
  20508.     solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], rhs, &ip[1], &data_1.np, &
  20509.         data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
  20510.         netcx_1.neq, &netcx_1.neq2, &neqz2);
  20511. /*<       CALL CABC( RHS) >*/
  20512.     cabc_(rhs);
  20513. /*<       DO 44  I=1, NTEQ >*/
  20514.     i__2 = nteq;
  20515.     for (i = 1; i <= i__2; ++i) {
  20516. /*<       IROW1= NTEQA( I) >*/
  20517.     irow1 = nteqa[i - 1];
  20518.  
  20519. /*     SOLVE NETWORK EQUATIONS */
  20520.  
  20521. /*<    44 RHNT( I)= RHNX( I)+ RHS( IROW1) >*/
  20522. /* L44: */
  20523.     i__1 = i - 1;
  20524.     i__3 = i - 1;
  20525.     i__5 = irow1 - 1;
  20526.     z__1.r = rhnx[i__3].r + rhs[i__5].r, z__1.i = rhnx[i__3].i + rhs[i__5]
  20527.         .i;
  20528.     rhnt[i__1].r = z__1.r, rhnt[i__1].i = z__1.i;
  20529.     }
  20530.  
  20531. /*     ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO */
  20532.  
  20533. /*     STRUCTURE AND SOLVE FOR INDUCED CURRENT */
  20534.  
  20535. /*<       CALL SOLVE( NTEQ, CMN, IPNT, RHNT, NDIMN) >*/
  20536.     solve_(&nteq, cmn, ipnt, rhnt, &ndimn);
  20537. /*<       DO 45  I=1, NTEQ >*/
  20538.     i__1 = nteq;
  20539.     for (i = 1; i <= i__1; ++i) {
  20540. /*<       IROW1= NTEQA( I) >*/
  20541.     irow1 = nteqa[i - 1];
  20542. /*<    45 EINC( IROW1)= EINC( IROW1)- RHNT( I) >*/
  20543. /* L45: */
  20544.     i__3 = irow1;
  20545.     i__5 = irow1;
  20546.     i__2 = i - 1;
  20547.     z__1.r = einc[i__5].r - rhnt[i__2].r, z__1.i = einc[i__5].i - rhnt[
  20548.         i__2].i;
  20549.     einc[i__3].r = z__1.r, einc[i__3].i = z__1.i;
  20550.     }
  20551. /*<    >*/
  20552.     solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], &einc[1], &ip[1], &data_1.np, &
  20553.         data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
  20554.         netcx_1.neq, &netcx_1.neq2, &neqz2);
  20555. /*<       CALL CABC( EINC) >*/
  20556.     cabc_(&einc[1]);
  20557. /*<       IF( NPRINT.EQ.0) WRITE( 6,61)  >*/
  20558.     if (netcx_1.nprint == 0) {
  20559.     s_wsfe(&io___1571);
  20560.     e_wsfe();
  20561.     }
  20562. /*<       IF( NPRINT.EQ.0) WRITE( 6,60)  >*/
  20563.     if (netcx_1.nprint == 0) {
  20564.     s_wsfe(&io___1572);
  20565.     e_wsfe();
  20566.     }
  20567. /*<       DO 46  I=1, NTEQ >*/
  20568.     i__3 = nteq;
  20569.     for (i = 1; i <= i__3; ++i) {
  20570. /*<       IROW1= NTEQA( I) >*/
  20571.     irow1 = nteqa[i - 1];
  20572. /*<       VLT= RHNT( I)* SI( IROW1)* WLAM >*/
  20573.     i__5 = i - 1;
  20574.     i__2 = irow1 - 1;
  20575.     z__2.r = data_1.si[i__2] * rhnt[i__5].r, z__2.i = data_1.si[i__2] * 
  20576.         rhnt[i__5].i;
  20577.     z__1.r = data_1.wlam * z__2.r, z__1.i = data_1.wlam * z__2.i;
  20578.     vlt.r = z__1.r, vlt.i = z__1.i;
  20579. /*<       CUX= EINC( IROW1)* WLAM >*/
  20580.     i__5 = irow1;
  20581.     z__1.r = data_1.wlam * einc[i__5].r, z__1.i = data_1.wlam * einc[i__5]
  20582.         .i;
  20583.     cux.r = z__1.r, cux.i = z__1.i;
  20584. /*<       YMIT= CUX/ VLT >*/
  20585.     z_div(&z__1, &cux, &vlt);
  20586.     ymit.r = z__1.r, ymit.i = z__1.i;
  20587. /*<       ZPED= VLT/ CUX >*/
  20588.     z_div(&z__1, &vlt, &cux);
  20589.     netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
  20590. /*<       IROW2= ITAG( IROW1) >*/
  20591.     irow2 = data_1.itag[irow1 - 1];
  20592. /*<       PWR=.5* REAL( VLT* CONJG( CUX)) >*/
  20593.     d_cnjg(&z__2, &cux);
  20594.     z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i + 
  20595.         vlt.i * z__2.r;
  20596.     pwr = z__1.r * .5;
  20597. /*<       PNLS= PNLS- PWR >*/
  20598.     netcx_1.pnls -= pwr;
  20599. /*<    >*/
  20600. /* L46: */
  20601.     if (netcx_1.nprint == 0) {
  20602.         s_wsfe(&io___1575);
  20603.         do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
  20604.         do_fio(&c__1, (char *)&irow1, (ftnlen)sizeof(integer));
  20605.         do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
  20606.         do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
  20607.         do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
  20608.         do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
  20609.         do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
  20610.         e_wsfe();
  20611.     }
  20612.     }
  20613. /*<       IF( NTSC.EQ.0) GOTO 49 >*/
  20614.     if (ntsc == 0) {
  20615.     goto L49;
  20616.     }
  20617. /*<       DO 47  I=1, NTSC >*/
  20618.     i__3 = ntsc;
  20619.     for (i = 1; i <= i__3; ++i) {
  20620. /*<       IROW1= NTSCA( I) >*/
  20621.     irow1 = ntsca[i - 1];
  20622. /*<       VLT= VSRC( I) >*/
  20623.     i__5 = i - 1;
  20624.     vlt.r = vsrc[i__5].r, vlt.i = vsrc[i__5].i;
  20625. /*<       CUX= EINC( IROW1)* WLAM >*/
  20626.     i__5 = irow1;
  20627.     z__1.r = data_1.wlam * einc[i__5].r, z__1.i = data_1.wlam * einc[i__5]
  20628.         .i;
  20629.     cux.r = z__1.r, cux.i = z__1.i;
  20630. /*<       YMIT= CUX/ VLT >*/
  20631.     z_div(&z__1, &cux, &vlt);
  20632.     ymit.r = z__1.r, ymit.i = z__1.i;
  20633. /*<       ZPED= VLT/ CUX >*/
  20634.     z_div(&z__1, &vlt, &cux);
  20635.     netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
  20636. /*<       IROW2= ITAG( IROW1) >*/
  20637.     irow2 = data_1.itag[irow1 - 1];
  20638. /*<       PWR=.5* REAL( VLT* CONJG( CUX)) >*/
  20639.     d_cnjg(&z__2, &cux);
  20640.     z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i + 
  20641.         vlt.i * z__2.r;
  20642.     pwr = z__1.r * .5;
  20643. /*<       PNLS= PNLS- PWR >*/
  20644.     netcx_1.pnls -= pwr;
  20645. /*<    >*/
  20646. /* L47: */
  20647.     if (netcx_1.nprint == 0) {
  20648.         s_wsfe(&io___1576);
  20649.         do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
  20650.         do_fio(&c__1, (char *)&irow1, (ftnlen)sizeof(integer));
  20651.         do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
  20652.         do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
  20653.         do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
  20654.         do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
  20655.         do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
  20656.         e_wsfe();
  20657.     }
  20658.     }
  20659.  
  20660. /*     SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT */
  20661.  
  20662. /*<       GOTO 49 >*/
  20663.     goto L49;
  20664. /*<    >*/
  20665. L48:
  20666.     solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], &einc[1], &ip[1], &data_1.np, &
  20667.         data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
  20668.         netcx_1.neq, &netcx_1.neq2, &neqz2);
  20669. /*<       CALL CABC( EINC) >*/
  20670.     cabc_(&einc[1]);
  20671. /*<       NTSC=0 >*/
  20672.     ntsc = 0;
  20673. /*<    49 IF( NSANT+ NVQD.EQ.0) RETURN >*/
  20674. L49:
  20675.     if (vsorc_1.nsant + vsorc_1.nvqd == 0) {
  20676.     return 0;
  20677.     }
  20678. /*<       WRITE( 6,63)  >*/
  20679.     s_wsfe(&io___1577);
  20680.     e_wsfe();
  20681. /*<       WRITE( 6,60)  >*/
  20682.     s_wsfe(&io___1578);
  20683.     e_wsfe();
  20684. /*<       IF( NSANT.EQ.0) GOTO 56 >*/
  20685.     if (vsorc_1.nsant == 0) {
  20686.     goto L56;
  20687.     }
  20688. /*<       DO 55  I=1, NSANT >*/
  20689.     i__3 = vsorc_1.nsant;
  20690.     for (i = 1; i <= i__3; ++i) {
  20691. /*<       ISC1= ISANT( I) >*/
  20692.     isc1 = vsorc_1.isant[i - 1];
  20693. /*<       VLT= VSANT( I) >*/
  20694.     i__5 = i - 1;
  20695.     vlt.r = vsorc_1.vsant[i__5].r, vlt.i = vsorc_1.vsant[i__5].i;
  20696. /*<       IF( NTSC.EQ.0) GOTO 51 >*/
  20697.     if (ntsc == 0) {
  20698.         goto L51;
  20699.     }
  20700. /*<       DO 50  J=1, NTSC >*/
  20701.     i__5 = ntsc;
  20702.     for (j = 1; j <= i__5; ++j) {
  20703. /*<       IF( NTSCA( J).EQ. ISC1) GOTO 52 >*/
  20704.         if (ntsca[j - 1] == isc1) {
  20705.         goto L52;
  20706.         }
  20707. /*<    50 CONTINUE >*/
  20708. /* L50: */
  20709.     }
  20710. /*<    51 CUX= EINC( ISC1)* WLAM >*/
  20711. L51:
  20712.     i__5 = isc1;
  20713.     z__1.r = data_1.wlam * einc[i__5].r, z__1.i = data_1.wlam * einc[i__5]
  20714.         .i;
  20715.     cux.r = z__1.r, cux.i = z__1.i;
  20716. /*<       IROW1=0 >*/
  20717.     irow1 = 0;
  20718. /*<       GOTO 54 >*/
  20719.     goto L54;
  20720. /*<    52 IROW1= NDIMNP- J >*/
  20721. L52:
  20722.     irow1 = ndimnp - j;
  20723. /*<       CUX= RHNX( IROW1) >*/
  20724.     i__5 = irow1 - 1;
  20725.     cux.r = rhnx[i__5].r, cux.i = rhnx[i__5].i;
  20726. /*<       DO 53  J=1, NTEQ >*/
  20727.     i__5 = nteq;
  20728.     for (j = 1; j <= i__5; ++j) {
  20729. /*<    53 CUX= CUX- CMN( J, IROW1)* RHNT( J) >*/
  20730. /* L53: */
  20731.         i__2 = j + irow1 * 150 - 151;
  20732.         i__1 = j - 1;
  20733.         z__2.r = cmn[i__2].r * rhnt[i__1].r - cmn[i__2].i * rhnt[i__1].i, 
  20734.             z__2.i = cmn[i__2].r * rhnt[i__1].i + cmn[i__2].i * rhnt[
  20735.             i__1].r;
  20736.         z__1.r = cux.r - z__2.r, z__1.i = cux.i - z__2.i;
  20737.         cux.r = z__1.r, cux.i = z__1.i;
  20738.     }
  20739. /*<       CUX=( EINC( ISC1)+ CUX)* WLAM >*/
  20740.     i__2 = isc1;
  20741.     z__2.r = einc[i__2].r + cux.r, z__2.i = einc[i__2].i + cux.i;
  20742.     z__1.r = data_1.wlam * z__2.r, z__1.i = data_1.wlam * z__2.i;
  20743.     cux.r = z__1.r, cux.i = z__1.i;
  20744. /*<    54 YMIT= CUX/ VLT >*/
  20745. L54:
  20746.     z_div(&z__1, &cux, &vlt);
  20747.     ymit.r = z__1.r, ymit.i = z__1.i;
  20748. /*<       ZPED= VLT/ CUX >*/
  20749.     z_div(&z__1, &vlt, &cux);
  20750.     netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
  20751. /*<       PWR=.5* REAL( VLT* CONJG( CUX)) >*/
  20752.     d_cnjg(&z__2, &cux);
  20753.     z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i + 
  20754.         vlt.i * z__2.r;
  20755.     pwr = z__1.r * .5;
  20756. /*<       PIN= PIN+ PWR >*/
  20757.     netcx_1.pin += pwr;
  20758. /*<       IF( IROW1.NE.0) PNLS= PNLS+ PWR >*/
  20759.     if (irow1 != 0) {
  20760.         netcx_1.pnls += pwr;
  20761.     }
  20762. /*<       IROW2= ITAG( ISC1) >*/
  20763.     irow2 = data_1.itag[isc1 - 1];
  20764. /*<    55 WRITE( 6,62)  IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR >*/
  20765. /* L55: */
  20766.     s_wsfe(&io___1579);
  20767.     do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
  20768.     do_fio(&c__1, (char *)&isc1, (ftnlen)sizeof(integer));
  20769.     do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
  20770.     do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
  20771.     do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
  20772.     do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
  20773.     do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
  20774.     e_wsfe();
  20775.     }
  20776. /*<    56 IF( NVQD.EQ.0) RETURN >*/
  20777. L56:
  20778.     if (vsorc_1.nvqd == 0) {
  20779.     return 0;
  20780.     }
  20781. /*<       DO 57  I=1, NVQD >*/
  20782.     i__3 = vsorc_1.nvqd;
  20783.     for (i = 1; i <= i__3; ++i) {
  20784. /*<       ISC1= IVQD( I) >*/
  20785.     isc1 = vsorc_1.ivqd[i - 1];
  20786. /*<       VLT= VQD( I) >*/
  20787.     i__2 = i - 1;
  20788.     vlt.r = vsorc_1.vqd[i__2].r, vlt.i = vsorc_1.vqd[i__2].i;
  20789. /*<       CUX= CMPLX( AIR( ISC1), AII( ISC1)) >*/
  20790.     i__2 = isc1 - 1;
  20791.     i__1 = isc1 - 1;
  20792.     z__1.r = crnt_1.air[i__2], z__1.i = crnt_1.aii[i__1];
  20793.     cux.r = z__1.r, cux.i = z__1.i;
  20794. /*<       YMIT= CMPLX( BIR( ISC1), BII( ISC1)) >*/
  20795.     i__2 = isc1 - 1;
  20796.     i__1 = isc1 - 1;
  20797.     z__1.r = crnt_1.bir[i__2], z__1.i = crnt_1.bii[i__1];
  20798.     ymit.r = z__1.r, ymit.i = z__1.i;
  20799. /*<       ZPED= CMPLX( CIR( ISC1), CII( ISC1)) >*/
  20800.     i__2 = isc1 - 1;
  20801.     i__1 = isc1 - 1;
  20802.     z__1.r = crnt_1.cir[i__2], z__1.i = crnt_1.cii[i__1];
  20803.     netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
  20804. /*<       PWR= SI( ISC1)* TP*.5 >*/
  20805.     d__1 = data_1.si[isc1 - 1] * tp;
  20806.     pwr = d__1 * .5;
  20807. /*<       CUX=( CUX- YMIT* SIN( PWR)+ ZPED* COS( PWR))* WLAM >*/
  20808.     d__1 = sin(pwr);
  20809.     z__4.r = d__1 * ymit.r, z__4.i = d__1 * ymit.i;
  20810.     z__3.r = cux.r - z__4.r, z__3.i = cux.i - z__4.i;
  20811.     d__2 = cos(pwr);
  20812.     z__5.r = d__2 * netcx_1.zped.r, z__5.i = d__2 * netcx_1.zped.i;
  20813.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  20814.     z__1.r = data_1.wlam * z__2.r, z__1.i = data_1.wlam * z__2.i;
  20815.     cux.r = z__1.r, cux.i = z__1.i;
  20816. /*<       YMIT= CUX/ VLT >*/
  20817.     z_div(&z__1, &cux, &vlt);
  20818.     ymit.r = z__1.r, ymit.i = z__1.i;
  20819. /*<       ZPED= VLT/ CUX >*/
  20820.     z_div(&z__1, &vlt, &cux);
  20821.     netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
  20822. /*<       PWR=.5* REAL( VLT* CONJG( CUX)) >*/
  20823.     d_cnjg(&z__2, &cux);
  20824.     z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i + 
  20825.         vlt.i * z__2.r;
  20826.     pwr = z__1.r * .5;
  20827. /*<       PIN= PIN+ PWR >*/
  20828.     netcx_1.pin += pwr;
  20829. /*<       IROW2= ITAG( ISC1) >*/
  20830.     irow2 = data_1.itag[isc1 - 1];
  20831. /*<    57 WRITE( 6,64)  IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR >*/
  20832. /* L57: */
  20833.     s_wsfe(&io___1580);
  20834.     do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
  20835.     do_fio(&c__1, (char *)&isc1, (ftnlen)sizeof(integer));
  20836.     do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
  20837.     do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
  20838.     do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
  20839.     do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
  20840.     do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
  20841.     e_wsfe();
  20842.     }
  20843.  
  20844. /*<       RETURN >*/
  20845.     return 0;
  20846. /*<    >*/
  20847. /*<    59 FORMAT(1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL') >*/
  20848. /*<    >*/
  20849. /*<    >*/
  20850. /*<    62 FORMAT(2(1X,I5),1P,9E12.5) >*/
  20851. /*<    63 FORMAT(///,42X,'- - - ANTENNA INPUT PARAMETERS - - -') >*/
  20852. /*<    64 FORMAT(1X,I5,' *',I4,1P,9E12.5) >*/
  20853. /*<       END >*/
  20854. } /* netwk_ */
  20855.  
  20856. /* *** */
  20857. /*     DOUBLE PRECISION 6/4/85 */
  20858.  
  20859. /*<       SUBROUTINE NFPAT >*/
  20860. /* Subroutine */ int nfpat_()
  20861. {
  20862.     /* Initialized data */
  20863.  
  20864.     static doublereal ta = .01745329252;
  20865.  
  20866.     /* Format strings */
  20867.     static char fmt_10[] = "(///,35x,\002- - - NEAR ELECTRIC FIELDS - - -\
  20868. \002,//,12x,\002-  L\002,\002OCATION  -\002,21x,\002-  EX  -\002,15x,\002-  \
  20869. EY  -\002,15x,\002-  EZ  -\002,/,8x,\002X\002,10x,\002Y\002,10x,\002Z\002,10\
  20870. x,\002MAGNITUDE\002,3x,\002PHASE\002,6x,\002MAGNITUDE\002,3x,\002PHASE\002,6\
  20871. x,\002MAGNITUDE\002,3x,\002PHASE\002,/,6x,\002METERS\002,5x,\002METERS\002,5\
  20872. x,\002METERS\002,8x,\002VOLTS/M\002,3x,\002DEGREES\002,6x,\002VOLTS/M\002,3x,\
  20873. \002DEGREES\002,6x,\002VOLTS/M\002,3x,\002DEGREES\002)";
  20874.     static char fmt_12[] = "(///,35x,\002- - - NEAR MAGNETIC FIELDS - - -\
  20875. \002,//,12x,\002-  L\002,\002OCATION  -\002,21x,\002-  HX  -\002,15x,\002-  \
  20876. HY  -\002,15x,\002-  HZ  -\002,/,8x,\002X\002,10x,\002Y\002,10x,\002Z\002,10\
  20877. x,\002MAGNITUDE\002,3x,\002PHASE\002,6x,\002MAGNITUDE\002,3x,\002PHASE\002,6\
  20878. x,\002MAGNITUDE\002,3x,\002PHASE\002,/,6x,\002METERS\002,5x,\002METERS\002,5\
  20879. x,\002METERS\002,9x,\002AMPS/M\002,3x,\002DEGREES\002,7x,\002AMPS/M\002,3x\
  20880. ,\002DEGREES\002,7x,\002AMPS/M\002,3x,\002DEGREES\002)";
  20881.     static char fmt_11[] = "(2x,3(2x,f9.4),1x,3(3x,1p,e11.4,2x,0p,f7.2))";
  20882.  
  20883.     /* System generated locals */
  20884.     integer i__1, i__2, i__3;
  20885.     doublereal d__1;
  20886.  
  20887.     /* Builtin functions */
  20888.     integer s_wsfe(), e_wsfe();
  20889.     double cos(), sin(), z_abs();
  20890.     integer do_fio(), s_wsle(), do_lio(), e_wsle();
  20891.  
  20892.     /* Local variables */
  20893.     extern doublereal cang_();
  20894.     static doublereal xnrt, ynrt, znrt;
  20895.     static integer i, j;
  20896.     extern /* Subroutine */ int nefld_(), nhfld_();
  20897.     static integer kk;
  20898.     static doublecomplex ex, ey, ez;
  20899.     static doublereal cth, cph, xob, sph, yob, zob, sth, xxx, tmp1, tmp2, 
  20900.         tmp3, tmp4, tmp5, tmp6;
  20901.  
  20902.     /* Fortran I/O blocks */
  20903.     static cilist io___1582 = { 0, 6, 0, fmt_10, 0 };
  20904.     static cilist io___1583 = { 0, 6, 0, fmt_12, 0 };
  20905.     static cilist io___1606 = { 0, 6, 0, fmt_11, 0 };
  20906.     static cilist io___1608 = { 0, 8, 0, 0, 0 };
  20907.     static cilist io___1609 = { 0, 8, 0, 0, 0 };
  20908.     static cilist io___1610 = { 0, 8, 0, 0, 0 };
  20909.     static cilist io___1611 = { 0, 8, 0, 0, 0 };
  20910.     static cilist io___1612 = { 0, 8, 0, 0, 0 };
  20911.     static cilist io___1613 = { 0, 8, 0, 0, 0 };
  20912.     static cilist io___1614 = { 0, 8, 0, 0, 0 };
  20913.     static cilist io___1615 = { 0, 8, 0, 0, 0 };
  20914.  
  20915.  
  20916. /* *** */
  20917. /*     COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS */
  20918. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  20919. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  20920. /*<       COMPLEX  EX, EY, EZ >*/
  20921. /*<    >*/
  20922. /* *** */
  20923. /*<    >*/
  20924. /* *** */
  20925. /*<       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
  20926. /*<       DATA   TA/1.745329252D-02/ >*/
  20927. /*<       IF( NFEH.EQ.1) GOTO 1 >*/
  20928.     if (fpat_1.nfeh == 1) {
  20929.     goto L1;
  20930.     }
  20931. /*<       WRITE( 6,10)  >*/
  20932.     s_wsfe(&io___1582);
  20933.     e_wsfe();
  20934. /*<       GOTO 2 >*/
  20935.     goto L2;
  20936. /*<     1 WRITE( 6,12)  >*/
  20937. L1:
  20938.     s_wsfe(&io___1583);
  20939.     e_wsfe();
  20940. /*<     2 ZNRT= ZNR- DZNR >*/
  20941. L2:
  20942.     znrt = fpat_1.znr - fpat_1.dznr;
  20943. /*<       DO 9  I=1, NRZ >*/
  20944.     i__1 = fpat_1.nrz;
  20945.     for (i = 1; i <= i__1; ++i) {
  20946. /*<       ZNRT= ZNRT+ DZNR >*/
  20947.     znrt += fpat_1.dznr;
  20948. /*<       IF( NEAR.EQ.0) GOTO 3 >*/
  20949.     if (fpat_1.near == 0) {
  20950.         goto L3;
  20951.     }
  20952. /*<       CTH= COS( TA* ZNRT) >*/
  20953.     cth = cos(ta * znrt);
  20954. /*<       STH= SIN( TA* ZNRT) >*/
  20955.     sth = sin(ta * znrt);
  20956. /*<     3 YNRT= YNR- DYNR >*/
  20957. L3:
  20958.     ynrt = fpat_1.ynr - fpat_1.dynr;
  20959. /*<       DO 9  J=1, NRY >*/
  20960.     i__2 = fpat_1.nry;
  20961.     for (j = 1; j <= i__2; ++j) {
  20962. /*<       YNRT= YNRT+ DYNR >*/
  20963.         ynrt += fpat_1.dynr;
  20964. /*<       IF( NEAR.EQ.0) GOTO 4 >*/
  20965.         if (fpat_1.near == 0) {
  20966.         goto L4;
  20967.         }
  20968. /*<       CPH= COS( TA* YNRT) >*/
  20969.         cph = cos(ta * ynrt);
  20970. /*<       SPH= SIN( TA* YNRT) >*/
  20971.         sph = sin(ta * ynrt);
  20972. /*<     4 XNRT= XNR- DXNR >*/
  20973. L4:
  20974.         xnrt = fpat_1.xnr - fpat_1.dxnr;
  20975. /*<       DO 9  KK=1, NRX >*/
  20976.         i__3 = fpat_1.nrx;
  20977.         for (kk = 1; kk <= i__3; ++kk) {
  20978. /*<       XNRT= XNRT+ DXNR >*/
  20979.         xnrt += fpat_1.dxnr;
  20980. /*<       IF( NEAR.EQ.0) GOTO 5 >*/
  20981.         if (fpat_1.near == 0) {
  20982.             goto L5;
  20983.         }
  20984. /*<       XOB= XNRT* STH* CPH >*/
  20985.         d__1 = xnrt * sth;
  20986.         xob = d__1 * cph;
  20987. /*<       YOB= XNRT* STH* SPH >*/
  20988.         d__1 = xnrt * sth;
  20989.         yob = d__1 * sph;
  20990. /*<       ZOB= XNRT* CTH >*/
  20991.         zob = xnrt * cth;
  20992. /*<       GOTO 6 >*/
  20993.         goto L6;
  20994. /*<     5 XOB= XNRT >*/
  20995. L5:
  20996.         xob = xnrt;
  20997. /*<       YOB= YNRT >*/
  20998.         yob = ynrt;
  20999. /*<       ZOB= ZNRT >*/
  21000.         zob = znrt;
  21001. /*<     6 TMP1= XOB/ WLAM >*/
  21002. L6:
  21003.         tmp1 = xob / data_1.wlam;
  21004. /*<       TMP2= YOB/ WLAM >*/
  21005.         tmp2 = yob / data_1.wlam;
  21006. /*<       TMP3= ZOB/ WLAM >*/
  21007.         tmp3 = zob / data_1.wlam;
  21008. /*<       IF( NFEH.EQ.1) GOTO 7 >*/
  21009.         if (fpat_1.nfeh == 1) {
  21010.             goto L7;
  21011.         }
  21012. /*<       CALL NEFLD( TMP1, TMP2, TMP3, EX, EY, EZ) >*/
  21013.         nefld_(&tmp1, &tmp2, &tmp3, &ex, &ey, &ez);
  21014. /*<       GOTO 8 >*/
  21015.         goto L8;
  21016. /*<     7 CALL NHFLD( TMP1, TMP2, TMP3, EX, EY, EZ) >*/
  21017. L7:
  21018.         nhfld_(&tmp1, &tmp2, &tmp3, &ex, &ey, &ez);
  21019. /*<     8 TMP1= ABS( EX) >*/
  21020. L8:
  21021.         tmp1 = z_abs(&ex);
  21022. /*<       TMP2= CANG( EX) >*/
  21023.         tmp2 = cang_(&ex);
  21024. /*<       TMP3= ABS( EY) >*/
  21025.         tmp3 = z_abs(&ey);
  21026. /*<       TMP4= CANG( EY) >*/
  21027.         tmp4 = cang_(&ey);
  21028. /*<       TMP5= ABS( EZ) >*/
  21029.         tmp5 = z_abs(&ez);
  21030. /*<       TMP6= CANG( EZ) >*/
  21031.         tmp6 = cang_(&ez);
  21032. /* *** */
  21033. /*<       WRITE( 6,11)  XOB, YOB, ZOB, TMP1, TMP2, TMP3, TMP4, TMP5, TMP6 >*/
  21034.         s_wsfe(&io___1606);
  21035.         do_fio(&c__1, (char *)&xob, (ftnlen)sizeof(doublereal));
  21036.         do_fio(&c__1, (char *)&yob, (ftnlen)sizeof(doublereal));
  21037.         do_fio(&c__1, (char *)&zob, (ftnlen)sizeof(doublereal));
  21038.         do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  21039.         do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  21040.         do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
  21041.         do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
  21042.         do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
  21043.         do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
  21044.         e_wsfe();
  21045. /*<       IF( IPLP1.NE.2) GOTO 9 >*/
  21046.         if (plot_1.iplp1 != 2) {
  21047.             goto L9;
  21048.         }
  21049. /*<       GOTO (14,15,16), IPLP4 >*/
  21050.         switch ((int)plot_1.iplp4) {
  21051.             case 1:  goto L14;
  21052.             case 2:  goto L15;
  21053.             case 3:  goto L16;
  21054.         }
  21055. /*<    14 XXX= XOB >*/
  21056. L14:
  21057.         xxx = xob;
  21058. /*<       GOTO 17 >*/
  21059.         goto L17;
  21060. /*<    15 XXX= YOB >*/
  21061. L15:
  21062.         xxx = yob;
  21063. /*<       GOTO 17 >*/
  21064.         goto L17;
  21065. /*<    16 XXX= ZOB >*/
  21066. L16:
  21067.         xxx = zob;
  21068. /*<    17 CONTINUE >*/
  21069. L17:
  21070. /*<       IF( IPLP2.NE.2) GOTO 13 >*/
  21071.         if (plot_1.iplp2 != 2) {
  21072.             goto L13;
  21073.         }
  21074. /*<       IF( IPLP3.EQ.1) WRITE( 8,*)  XXX, TMP1, TMP2 >*/
  21075.         if (plot_1.iplp3 == 1) {
  21076.             s_wsle(&io___1608);
  21077.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21078.                 doublereal));
  21079.             do_lio(&c__5, &c__1, (char *)&tmp1, (ftnlen)sizeof(
  21080.                 doublereal));
  21081.             do_lio(&c__5, &c__1, (char *)&tmp2, (ftnlen)sizeof(
  21082.                 doublereal));
  21083.             e_wsle();
  21084.         }
  21085. /*<       IF( IPLP3.EQ.2) WRITE( 8,*)  XXX, TMP3, TMP4 >*/
  21086.         if (plot_1.iplp3 == 2) {
  21087.             s_wsle(&io___1609);
  21088.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21089.                 doublereal));
  21090.             do_lio(&c__5, &c__1, (char *)&tmp3, (ftnlen)sizeof(
  21091.                 doublereal));
  21092.             do_lio(&c__5, &c__1, (char *)&tmp4, (ftnlen)sizeof(
  21093.                 doublereal));
  21094.             e_wsle();
  21095.         }
  21096. /*<       IF( IPLP3.EQ.3) WRITE( 8,*)  XXX, TMP5, TMP6 >*/
  21097.         if (plot_1.iplp3 == 3) {
  21098.             s_wsle(&io___1610);
  21099.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21100.                 doublereal));
  21101.             do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(
  21102.                 doublereal));
  21103.             do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(
  21104.                 doublereal));
  21105.             e_wsle();
  21106.         }
  21107. /*<    >*/
  21108.         if (plot_1.iplp3 == 4) {
  21109.             s_wsle(&io___1611);
  21110.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21111.                 doublereal));
  21112.             do_lio(&c__5, &c__1, (char *)&tmp1, (ftnlen)sizeof(
  21113.                 doublereal));
  21114.             do_lio(&c__5, &c__1, (char *)&tmp2, (ftnlen)sizeof(
  21115.                 doublereal));
  21116.             do_lio(&c__5, &c__1, (char *)&tmp3, (ftnlen)sizeof(
  21117.                 doublereal));
  21118.             do_lio(&c__5, &c__1, (char *)&tmp4, (ftnlen)sizeof(
  21119.                 doublereal));
  21120.             do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(
  21121.                 doublereal));
  21122.             do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(
  21123.                 doublereal));
  21124.             e_wsle();
  21125.         }
  21126. /*<       GOTO 9 >*/
  21127.         goto L9;
  21128. /*<    13 IF( IPLP2.NE.1) GOTO 9 >*/
  21129. L13:
  21130.         if (plot_1.iplp2 != 1) {
  21131.             goto L9;
  21132.         }
  21133. /*<       IF( IPLP3.EQ.1) WRITE( 8,*)  XXX, EX >*/
  21134.         if (plot_1.iplp3 == 1) {
  21135.             s_wsle(&io___1612);
  21136.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21137.                 doublereal));
  21138.             do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(
  21139.                 doublecomplex));
  21140.             e_wsle();
  21141.         }
  21142. /*<       IF( IPLP3.EQ.2) WRITE( 8,*)  XXX, EY >*/
  21143.         if (plot_1.iplp3 == 2) {
  21144.             s_wsle(&io___1613);
  21145.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21146.                 doublereal));
  21147.             do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(
  21148.                 doublecomplex));
  21149.             e_wsle();
  21150.         }
  21151. /*<       IF( IPLP3.EQ.3) WRITE( 8,*)  XXX, EZ >*/
  21152.         if (plot_1.iplp3 == 3) {
  21153.             s_wsle(&io___1614);
  21154.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21155.                 doublereal));
  21156.             do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(
  21157.                 doublecomplex));
  21158.             e_wsle();
  21159.         }
  21160. /* *** */
  21161. /*<       IF( IPLP3.EQ.4) WRITE( 8,*)  XXX, EX, EY, EZ >*/
  21162.         if (plot_1.iplp3 == 4) {
  21163.             s_wsle(&io___1615);
  21164.             do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
  21165.                 doublereal));
  21166.             do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(
  21167.                 doublecomplex));
  21168.             do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(
  21169.                 doublecomplex));
  21170.             do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(
  21171.                 doublecomplex));
  21172.             e_wsle();
  21173.         }
  21174. /*<     9 CONTINUE >*/
  21175. L9:
  21176.         ;
  21177.         }
  21178.     }
  21179.     }
  21180.  
  21181. /*<       RETURN >*/
  21182.     return 0;
  21183. /*<    >*/
  21184. /*<    11 FORMAT(2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2)) >*/
  21185. /*<    >*/
  21186. /*<       END >*/
  21187. } /* nfpat_ */
  21188.  
  21189. /* *** */
  21190. /*     DOUBLE PRECISION 6/4/85 */
  21191.  
  21192. /*<       SUBROUTINE NHFLD( XOB, YOB, ZOB, HX, HY, HZ) >*/
  21193. /* Subroutine */ int nhfld_(xob, yob, zob, hx, hy, hz)
  21194. doublereal *xob, *yob, *zob;
  21195. doublecomplex *hx, *hy, *hz;
  21196. {
  21197.     /* System generated locals */
  21198.     integer i__1, i__2, i__3, i__4;
  21199.     doublereal d__1;
  21200.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
  21201.  
  21202.     /* Local variables */
  21203.     static integer i;
  21204.     extern /* Subroutine */ int hsfld_(), hintg_();
  21205.     static integer jc, jl;
  21206.     static doublereal ax, zp;
  21207. #define xs ((doublereal *)&data_1)
  21208. #define ys ((doublereal *)&data_1 + 600)
  21209. #define zs ((doublereal *)&data_1 + 1200)
  21210. #define t1x ((doublereal *)&data_1 + 1800)
  21211. #define t1y ((doublereal *)&data_1 + 3000)
  21212. #define t1z ((doublereal *)&data_1 + 3600)
  21213. #define t2x ((doublereal *)&data_1 + 4201)
  21214. #define t2y ((doublereal *)&data_1 + 4601)
  21215. #define t2z ((doublereal *)&data_1 + 5001)
  21216. #define cab ((doublereal *)&data_1 + 3000)
  21217. #define sab ((doublereal *)&data_1 + 3600)
  21218.     static doublecomplex acx, bcx, ccx;
  21219. #define t1xj ((doublereal *)&dataj_1 + 5)
  21220. #define t1yj ((doublereal *)&dataj_1 + 6)
  21221. #define t1zj ((doublereal *)&dataj_1 + 7)
  21222. #define t2xj ((doublereal *)&dataj_1 + 1)
  21223. #define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
  21224. #define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
  21225.  
  21226. /* *** */
  21227.  
  21228. /*     NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER */
  21229.  
  21230. /*     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED. */
  21231.  
  21232. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  21233. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  21234. /*<    >*/
  21235. /*<    >*/
  21236. /*<       COMMON  /ANGL/ SALP( NM) >*/
  21237. /*<    >*/
  21238. /*<    >*/
  21239. /*<       DIMENSION  CAB(1), SAB(1) >*/
  21240. /*<    >*/
  21241. /*<    >*/
  21242. /*<    >*/
  21243. /*<       EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
  21244. /*<       HX=(0.,0.) >*/
  21245.     hx->r = 0., hx->i = 0.;
  21246. /*<       HY=(0.,0.) >*/
  21247.     hy->r = 0., hy->i = 0.;
  21248. /*<       HZ=(0.,0.) >*/
  21249.     hz->r = 0., hz->i = 0.;
  21250. /*<       AX=0. >*/
  21251.     ax = 0.;
  21252. /*<       IF( N.EQ.0) GOTO 4 >*/
  21253.     if (data_1.n == 0) {
  21254.     goto L4;
  21255.     }
  21256. /*<       DO 1  I=1, N >*/
  21257.     i__1 = data_1.n;
  21258.     for (i = 1; i <= i__1; ++i) {
  21259. /*<       XJ= XOB- X( I) >*/
  21260.     dataj_1.xj = *xob - data_1.x[i - 1];
  21261. /*<       YJ= YOB- Y( I) >*/
  21262.     dataj_1.yj = *yob - data_1.y[i - 1];
  21263. /*<       ZJ= ZOB- Z( I) >*/
  21264.     dataj_1.zj = *zob - data_1.z[i - 1];
  21265. /*<       ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ >*/
  21266.     d__1 = cab[i - 1] * dataj_1.xj + sab[i - 1] * dataj_1.yj;
  21267.     zp = d__1 + angl_1.salp[i - 1] * dataj_1.zj;
  21268. /*<       IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1 >*/
  21269.     if (abs(zp) > data_1.si[i - 1] * .5001) {
  21270.         goto L1;
  21271.     }
  21272. /*<       ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP >*/
  21273.     d__1 = dataj_1.xj * dataj_1.xj + dataj_1.yj * dataj_1.yj;
  21274.     zp = d__1 + dataj_1.zj * dataj_1.zj - zp * zp;
  21275. /*<       XJ= BI( I) >*/
  21276.     dataj_1.xj = data_1.bi[i - 1];
  21277. /*<       IF( ZP.GT.0.9* XJ* XJ) GOTO 1 >*/
  21278.     d__1 = dataj_1.xj * .9;
  21279.     if (zp > d__1 * dataj_1.xj) {
  21280.         goto L1;
  21281.     }
  21282. /*<       AX= XJ >*/
  21283.     ax = dataj_1.xj;
  21284. /*<       GOTO 2 >*/
  21285.     goto L2;
  21286. /*<     1 CONTINUE >*/
  21287. L1:
  21288.     ;
  21289.     }
  21290. /*<     2 DO 3  I=1, N >*/
  21291. L2:
  21292.     i__1 = data_1.n;
  21293.     for (i = 1; i <= i__1; ++i) {
  21294. /*<       S= SI( I) >*/
  21295.     dataj_1.s = data_1.si[i - 1];
  21296. /*<       B= BI( I) >*/
  21297.     dataj_1.b = data_1.bi[i - 1];
  21298. /*<       XJ= X( I) >*/
  21299.     dataj_1.xj = data_1.x[i - 1];
  21300. /*<       YJ= Y( I) >*/
  21301.     dataj_1.yj = data_1.y[i - 1];
  21302. /*<       ZJ= Z( I) >*/
  21303.     dataj_1.zj = data_1.z[i - 1];
  21304. /*<       CABJ= CAB( I) >*/
  21305.     dataj_1.cabj = cab[i - 1];
  21306. /*<       SABJ= SAB( I) >*/
  21307.     dataj_1.sabj = sab[i - 1];
  21308. /*<       SALPJ= SALP( I) >*/
  21309.     dataj_1.salpj = angl_1.salp[i - 1];
  21310. /*<       CALL HSFLD( XOB, YOB, ZOB, AX) >*/
  21311.     hsfld_(xob, yob, zob, &ax);
  21312. /*<       ACX= CMPLX( AIR( I), AII( I)) >*/
  21313.     i__2 = i - 1;
  21314.     i__3 = i - 1;
  21315.     z__1.r = crnt_1.air[i__2], z__1.i = crnt_1.aii[i__3];
  21316.     acx.r = z__1.r, acx.i = z__1.i;
  21317. /*<       BCX= CMPLX( BIR( I), BII( I)) >*/
  21318.     i__2 = i - 1;
  21319.     i__3 = i - 1;
  21320.     z__1.r = crnt_1.bir[i__2], z__1.i = crnt_1.bii[i__3];
  21321.     bcx.r = z__1.r, bcx.i = z__1.i;
  21322. /*<       CCX= CMPLX( CIR( I), CII( I)) >*/
  21323.     i__2 = i - 1;
  21324.     i__3 = i - 1;
  21325.     z__1.r = crnt_1.cir[i__2], z__1.i = crnt_1.cii[i__3];
  21326.     ccx.r = z__1.r, ccx.i = z__1.i;
  21327. /*<       HX= HX+ EXK* ACX+ EXS* BCX+ EXC* CCX >*/
  21328.     z__4.r = dataj_1.exk.r * acx.r - dataj_1.exk.i * acx.i, z__4.i = 
  21329.         dataj_1.exk.r * acx.i + dataj_1.exk.i * acx.r;
  21330.     z__3.r = hx->r + z__4.r, z__3.i = hx->i + z__4.i;
  21331.     z__5.r = dataj_1.exs.r * bcx.r - dataj_1.exs.i * bcx.i, z__5.i = 
  21332.         dataj_1.exs.r * bcx.i + dataj_1.exs.i * bcx.r;
  21333.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  21334.     z__6.r = dataj_1.exc.r * ccx.r - dataj_1.exc.i * ccx.i, z__6.i = 
  21335.         dataj_1.exc.r * ccx.i + dataj_1.exc.i * ccx.r;
  21336.     z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  21337.     hx->r = z__1.r, hx->i = z__1.i;
  21338. /*<       HY= HY+ EYK* ACX+ EYS* BCX+ EYC* CCX >*/
  21339.     z__4.r = dataj_1.eyk.r * acx.r - dataj_1.eyk.i * acx.i, z__4.i = 
  21340.         dataj_1.eyk.r * acx.i + dataj_1.eyk.i * acx.r;
  21341.     z__3.r = hy->r + z__4.r, z__3.i = hy->i + z__4.i;
  21342.     z__5.r = dataj_1.eys.r * bcx.r - dataj_1.eys.i * bcx.i, z__5.i = 
  21343.         dataj_1.eys.r * bcx.i + dataj_1.eys.i * bcx.r;
  21344.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  21345.     z__6.r = dataj_1.eyc.r * ccx.r - dataj_1.eyc.i * ccx.i, z__6.i = 
  21346.         dataj_1.eyc.r * ccx.i + dataj_1.eyc.i * ccx.r;
  21347.     z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  21348.     hy->r = z__1.r, hy->i = z__1.i;
  21349. /*<     3 HZ= HZ+ EZK* ACX+ EZS* BCX+ EZC* CCX >*/
  21350. /* L3: */
  21351.     z__4.r = dataj_1.ezk.r * acx.r - dataj_1.ezk.i * acx.i, z__4.i = 
  21352.         dataj_1.ezk.r * acx.i + dataj_1.ezk.i * acx.r;
  21353.     z__3.r = hz->r + z__4.r, z__3.i = hz->i + z__4.i;
  21354.     z__5.r = dataj_1.ezs.r * bcx.r - dataj_1.ezs.i * bcx.i, z__5.i = 
  21355.         dataj_1.ezs.r * bcx.i + dataj_1.ezs.i * bcx.r;
  21356.     z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
  21357.     z__6.r = dataj_1.ezc.r * ccx.r - dataj_1.ezc.i * ccx.i, z__6.i = 
  21358.         dataj_1.ezc.r * ccx.i + dataj_1.ezc.i * ccx.r;
  21359.     z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
  21360.     hz->r = z__1.r, hz->i = z__1.i;
  21361.     }
  21362. /*<       IF( M.EQ.0) RETURN >*/
  21363.     if (data_1.m == 0) {
  21364.     return 0;
  21365.     }
  21366. /*<     4 JC= N >*/
  21367. L4:
  21368.     jc = data_1.n;
  21369. /*<       JL= LD+1 >*/
  21370.     jl = data_1.ld + 1;
  21371. /*<       DO 5  I=1, M >*/
  21372.     i__1 = data_1.m;
  21373.     for (i = 1; i <= i__1; ++i) {
  21374. /*<       JL= JL-1 >*/
  21375.     --jl;
  21376. /*<       S= BI( JL) >*/
  21377.     dataj_1.s = data_1.bi[jl - 1];
  21378. /*<       XJ= X( JL) >*/
  21379.     dataj_1.xj = data_1.x[jl - 1];
  21380. /*<       YJ= Y( JL) >*/
  21381.     dataj_1.yj = data_1.y[jl - 1];
  21382. /*<       ZJ= Z( JL) >*/
  21383.     dataj_1.zj = data_1.z[jl - 1];
  21384. /*<       T1XJ= T1X( JL) >*/
  21385.     *t1xj = t1x[jl - 1];
  21386. /*<       T1YJ= T1Y( JL) >*/
  21387.     *t1yj = t1y[jl - 1];
  21388. /*<       T1ZJ= T1Z( JL) >*/
  21389.     *t1zj = t1z[jl - 1];
  21390. /*<       T2XJ= T2X( JL) >*/
  21391.     *t2xj = t2x[jl - 1];
  21392. /*<       T2YJ= T2Y( JL) >*/
  21393.     *t2yj = t2y[jl - 1];
  21394. /*<       T2ZJ= T2Z( JL) >*/
  21395.     *t2zj = t2z[jl - 1];
  21396. /*<       CALL HINTG( XOB, YOB, ZOB) >*/
  21397.     hintg_(xob, yob, zob);
  21398. /*<       JC= JC+3 >*/
  21399.     jc += 3;
  21400. /*<       ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC) >*/
  21401.     i__2 = jc - 3;
  21402.     z__3.r = *t1xj * crnt_1.cur[i__2].r, z__3.i = *t1xj * crnt_1.cur[i__2]
  21403.         .i;
  21404.     i__3 = jc - 2;
  21405.     z__4.r = *t1yj * crnt_1.cur[i__3].r, z__4.i = *t1yj * crnt_1.cur[i__3]
  21406.         .i;
  21407.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  21408.     i__4 = jc - 1;
  21409.     z__5.r = *t1zj * crnt_1.cur[i__4].r, z__5.i = *t1zj * crnt_1.cur[i__4]
  21410.         .i;
  21411.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  21412.     acx.r = z__1.r, acx.i = z__1.i;
  21413. /*<       BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC) >*/
  21414.     i__2 = jc - 3;
  21415.     z__3.r = *t2xj * crnt_1.cur[i__2].r, z__3.i = *t2xj * crnt_1.cur[i__2]
  21416.         .i;
  21417.     i__3 = jc - 2;
  21418.     z__4.r = *t2yj * crnt_1.cur[i__3].r, z__4.i = *t2yj * crnt_1.cur[i__3]
  21419.         .i;
  21420.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  21421.     i__4 = jc - 1;
  21422.     z__5.r = *t2zj * crnt_1.cur[i__4].r, z__5.i = *t2zj * crnt_1.cur[i__4]
  21423.         .i;
  21424.     z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  21425.     bcx.r = z__1.r, bcx.i = z__1.i;
  21426. /*<       HX= HX+ ACX* EXK+ BCX* EXS >*/
  21427.     z__3.r = acx.r * dataj_1.exk.r - acx.i * dataj_1.exk.i, z__3.i = 
  21428.         acx.r * dataj_1.exk.i + acx.i * dataj_1.exk.r;
  21429.     z__2.r = hx->r + z__3.r, z__2.i = hx->i + z__3.i;
  21430.     z__4.r = bcx.r * dataj_1.exs.r - bcx.i * dataj_1.exs.i, z__4.i = 
  21431.         bcx.r * dataj_1.exs.i + bcx.i * dataj_1.exs.r;
  21432.     z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  21433.     hx->r = z__1.r, hx->i = z__1.i;
  21434. /*<       HY= HY+ ACX* EYK+ BCX* EYS >*/
  21435.     z__3.r = acx.r * dataj_1.eyk.r - acx.i * dataj_1.eyk.i, z__3.i = 
  21436.         acx.r * dataj_1.eyk.i + acx.i * dataj_1.eyk.r;
  21437.     z__2.r = hy->r + z__3.r, z__2.i = hy->i + z__3.i;
  21438.     z__4.r = bcx.r * dataj_1.eys.r - bcx.i * dataj_1.eys.i, z__4.i = 
  21439.         bcx.r * dataj_1.eys.i + bcx.i * dataj_1.eys.r;
  21440.     z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  21441.     hy->r = z__1.r, hy->i = z__1.i;
  21442. /*<     5 HZ= HZ+ ACX* EZK+ BCX* EZS >*/
  21443. /* L5: */
  21444.     z__3.r = acx.r * dataj_1.ezk.r - acx.i * dataj_1.ezk.i, z__3.i = 
  21445.         acx.r * dataj_1.ezk.i + acx.i * dataj_1.ezk.r;
  21446.     z__2.r = hz->r + z__3.r, z__2.i = hz->i + z__3.i;
  21447.     z__4.r = bcx.r * dataj_1.ezs.r - bcx.i * dataj_1.ezs.i, z__4.i = 
  21448.         bcx.r * dataj_1.ezs.i + bcx.i * dataj_1.ezs.r;
  21449.     z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  21450.     hz->r = z__1.r, hz->i = z__1.i;
  21451.     }
  21452. /*<       RETURN >*/
  21453.     return 0;
  21454. /*<       END >*/
  21455. } /* nhfld_ */
  21456.  
  21457. #undef t2zj
  21458. #undef t2yj
  21459. #undef t2xj
  21460. #undef t1zj
  21461. #undef t1yj
  21462. #undef t1xj
  21463. #undef sab
  21464. #undef cab
  21465. #undef t2z
  21466. #undef t2y
  21467. #undef t2x
  21468. #undef t1z
  21469. #undef t1y
  21470. #undef t1x
  21471. #undef zs
  21472. #undef ys
  21473. #undef xs
  21474.  
  21475.  
  21476. /* *** */
  21477. /*     DOUBLE PRECISION 6/4/85 */
  21478.  
  21479. /*<    >*/
  21480. /* Subroutine */ int patch_0_(n__, nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3,
  21481.      x4, y4, z4)
  21482. int n__;
  21483. integer *nx, *ny;
  21484. doublereal *x1, *y1, *z1, *x2, *y2, *z2, *x3, *y3, *z3, *x4, *y4, *z4;
  21485. {
  21486.     /* Format strings */
  21487.     static char fmt_14[] = "(\002 ERROR -- CORNERS OF QUADRILATERAL PATCH DO\
  21488.  NOT LIE IN \002,\002A PLANE\002)";
  21489.  
  21490.     /* System generated locals */
  21491.     integer i__1, i__2;
  21492.     doublereal d__1, d__2;
  21493.  
  21494.     /* Builtin functions */
  21495.     double cos(), sin(), sqrt();
  21496.     integer s_wsfe(), e_wsfe();
  21497.     /* Subroutine */ int s_stop();
  21498.  
  21499.     /* Local variables */
  21500.     static doublereal saln, salpn;
  21501.     static integer mi;
  21502.     static doublereal xa;
  21503.     static integer ix, iy;
  21504.     static doublereal xs, ys, zs, xt, yt, zt, xn2, yn2, zn2, s1x;
  21505. #define t1x ((doublereal *)&data_1 + 1800)
  21506. #define t1y ((doublereal *)&data_1 + 3000)
  21507. #define t1z ((doublereal *)&data_1 + 3600)
  21508. #define t2x ((doublereal *)&data_1 + 4201)
  21509. #define t2y ((doublereal *)&data_1 + 4601)
  21510. #define t2z ((doublereal *)&data_1 + 5001)
  21511.     static doublereal s1y, s1z, s2x, s2y, s2z;
  21512.     static integer mia, ntp, nxp, nyp;
  21513.     static doublereal xnv, ynv, znv, xst;
  21514.  
  21515.     /* Fortran I/O blocks */
  21516.     static cilist io___1664 = { 0, 6, 0, fmt_14, 0 };
  21517.  
  21518.  
  21519. /* *** */
  21520. /*     PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA */
  21521. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  21522. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  21523. /*<    >*/
  21524. /*<       COMMON  /ANGL/ SALP( NM) >*/
  21525. /*<       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
  21526. /*     NEW PATCHES.  FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY) */
  21527. /*     ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL. */
  21528. /*     FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH */
  21529. /*     NX BY NY RECTANGULAR PATCHES. */
  21530. /*<    >*/
  21531. /*<       M= M+1 >*/
  21532.     switch(n__) {
  21533.     case 1: goto L_subph;
  21534.     }
  21535.  
  21536.     ++data_1.m;
  21537. /*<       MI= LD+1- M >*/
  21538.     mi = data_1.ld + 1 - data_1.m;
  21539. /*<       NTP= NY >*/
  21540.     ntp = *ny;
  21541. /*<       IF( NX.GT.0) NTP=2 >*/
  21542.     if (*nx > 0) {
  21543.     ntp = 2;
  21544.     }
  21545. /*<       IF( NTP.GT.1) GOTO 2 >*/
  21546.     if (ntp > 1) {
  21547.     goto L2;
  21548.     }
  21549. /*<       X( MI)= X1 >*/
  21550.     data_1.x[mi - 1] = *x1;
  21551. /*<       Y( MI)= Y1 >*/
  21552.     data_1.y[mi - 1] = *y1;
  21553. /*<       Z( MI)= Z1 >*/
  21554.     data_1.z[mi - 1] = *z1;
  21555. /*<       BI( MI)= Z2 >*/
  21556.     data_1.bi[mi - 1] = *z2;
  21557. /*<       ZNV= COS( X2) >*/
  21558.     znv = cos(*x2);
  21559. /*<       XNV= ZNV* COS( Y2) >*/
  21560.     xnv = znv * cos(*y2);
  21561. /*<       YNV= ZNV* SIN( Y2) >*/
  21562.     ynv = znv * sin(*y2);
  21563. /*<       ZNV= SIN( X2) >*/
  21564.     znv = sin(*x2);
  21565. /*<       XA= SQRT( XNV* XNV+ YNV* YNV) >*/
  21566.     xa = sqrt(xnv * xnv + ynv * ynv);
  21567. /*<       IF( XA.LT.1.D-6) GOTO 1 >*/
  21568.     if (xa < 1e-6) {
  21569.     goto L1;
  21570.     }
  21571. /*<       T1X( MI)=- YNV/ XA >*/
  21572.     t1x[mi - 1] = -ynv / xa;
  21573. /*<       T1Y( MI)= XNV/ XA >*/
  21574.     t1y[mi - 1] = xnv / xa;
  21575. /*<       T1Z( MI)=0. >*/
  21576.     t1z[mi - 1] = 0.;
  21577. /*<       GOTO 6 >*/
  21578.     goto L6;
  21579. /*<     1 T1X( MI)=1. >*/
  21580. L1:
  21581.     t1x[mi - 1] = 1.;
  21582. /*<       T1Y( MI)=0. >*/
  21583.     t1y[mi - 1] = 0.;
  21584. /*<       T1Z( MI)=0. >*/
  21585.     t1z[mi - 1] = 0.;
  21586. /*<       GOTO 6 >*/
  21587.     goto L6;
  21588. /*<     2 S1X= X2- X1 >*/
  21589. L2:
  21590.     s1x = *x2 - *x1;
  21591. /*<       S1Y= Y2- Y1 >*/
  21592.     s1y = *y2 - *y1;
  21593. /*<       S1Z= Z2- Z1 >*/
  21594.     s1z = *z2 - *z1;
  21595. /*<       S2X= X3- X2 >*/
  21596.     s2x = *x3 - *x2;
  21597. /*<       S2Y= Y3- Y2 >*/
  21598.     s2y = *y3 - *y2;
  21599. /*<       S2Z= Z3- Z2 >*/
  21600.     s2z = *z3 - *z2;
  21601. /*<       IF( NX.EQ.0) GOTO 3 >*/
  21602.     if (*nx == 0) {
  21603.     goto L3;
  21604.     }
  21605. /*<       S1X= S1X/ NX >*/
  21606.     s1x /= *nx;
  21607. /*<       S1Y= S1Y/ NX >*/
  21608.     s1y /= *nx;
  21609. /*<       S1Z= S1Z/ NX >*/
  21610.     s1z /= *nx;
  21611. /*<       S2X= S2X/ NY >*/
  21612.     s2x /= *ny;
  21613. /*<       S2Y= S2Y/ NY >*/
  21614.     s2y /= *ny;
  21615. /*<       S2Z= S2Z/ NY >*/
  21616.     s2z /= *ny;
  21617. /*<     3 XNV= S1Y* S2Z- S1Z* S2Y >*/
  21618. L3:
  21619.     xnv = s1y * s2z - s1z * s2y;
  21620. /*<       YNV= S1Z* S2X- S1X* S2Z >*/
  21621.     ynv = s1z * s2x - s1x * s2z;
  21622. /*<       ZNV= S1X* S2Y- S1Y* S2X >*/
  21623.     znv = s1x * s2y - s1y * s2x;
  21624. /*<       XA= SQRT( XNV* XNV+ YNV* YNV+ ZNV* ZNV) >*/
  21625.     d__1 = xnv * xnv + ynv * ynv;
  21626.     xa = sqrt(d__1 + znv * znv);
  21627. /*<       XNV= XNV/ XA >*/
  21628.     xnv /= xa;
  21629. /*<       YNV= YNV/ XA >*/
  21630.     ynv /= xa;
  21631. /*<       ZNV= ZNV/ XA >*/
  21632.     znv /= xa;
  21633. /*<       XST= SQRT( S1X* S1X+ S1Y* S1Y+ S1Z* S1Z) >*/
  21634.     d__1 = s1x * s1x + s1y * s1y;
  21635.     xst = sqrt(d__1 + s1z * s1z);
  21636. /*<       T1X( MI)= S1X/ XST >*/
  21637.     t1x[mi - 1] = s1x / xst;
  21638. /*<       T1Y( MI)= S1Y/ XST >*/
  21639.     t1y[mi - 1] = s1y / xst;
  21640. /*<       T1Z( MI)= S1Z/ XST >*/
  21641.     t1z[mi - 1] = s1z / xst;
  21642. /*<       IF( NTP.GT.2) GOTO 4 >*/
  21643.     if (ntp > 2) {
  21644.     goto L4;
  21645.     }
  21646. /*<       X( MI)= X1+.5*( S1X+ S2X) >*/
  21647.     data_1.x[mi - 1] = *x1 + (s1x + s2x) * .5;
  21648. /*<       Y( MI)= Y1+.5*( S1Y+ S2Y) >*/
  21649.     data_1.y[mi - 1] = *y1 + (s1y + s2y) * .5;
  21650. /*<       Z( MI)= Z1+.5*( S1Z+ S2Z) >*/
  21651.     data_1.z[mi - 1] = *z1 + (s1z + s2z) * .5;
  21652. /*<       BI( MI)= XA >*/
  21653.     data_1.bi[mi - 1] = xa;
  21654. /*<       GOTO 6 >*/
  21655.     goto L6;
  21656. /*<     4 IF( NTP.EQ.4) GOTO 5 >*/
  21657. L4:
  21658.     if (ntp == 4) {
  21659.     goto L5;
  21660.     }
  21661. /*<       X( MI)=( X1+ X2+ X3)/3. >*/
  21662.     d__1 = *x1 + *x2;
  21663.     data_1.x[mi - 1] = (d__1 + *x3) / 3.;
  21664. /*<       Y( MI)=( Y1+ Y2+ Y3)/3. >*/
  21665.     d__1 = *y1 + *y2;
  21666.     data_1.y[mi - 1] = (d__1 + *y3) / 3.;
  21667. /*<       Z( MI)=( Z1+ Z2+ Z3)/3. >*/
  21668.     d__1 = *z1 + *z2;
  21669.     data_1.z[mi - 1] = (d__1 + *z3) / 3.;
  21670. /*<       BI( MI)=.5* XA >*/
  21671.     data_1.bi[mi - 1] = xa * .5;
  21672. /*<       GOTO 6 >*/
  21673.     goto L6;
  21674. /*<     5 S1X= X3- X1 >*/
  21675. L5:
  21676.     s1x = *x3 - *x1;
  21677. /*<       S1Y= Y3- Y1 >*/
  21678.     s1y = *y3 - *y1;
  21679. /*<       S1Z= Z3- Z1 >*/
  21680.     s1z = *z3 - *z1;
  21681. /*<       S2X= X4- X1 >*/
  21682.     s2x = *x4 - *x1;
  21683. /*<       S2Y= Y4- Y1 >*/
  21684.     s2y = *y4 - *y1;
  21685. /*<       S2Z= Z4- Z1 >*/
  21686.     s2z = *z4 - *z1;
  21687. /*<       XN2= S1Y* S2Z- S1Z* S2Y >*/
  21688.     xn2 = s1y * s2z - s1z * s2y;
  21689. /*<       YN2= S1Z* S2X- S1X* S2Z >*/
  21690.     yn2 = s1z * s2x - s1x * s2z;
  21691. /*<       ZN2= S1X* S2Y- S1Y* S2X >*/
  21692.     zn2 = s1x * s2y - s1y * s2x;
  21693. /*<       XST= SQRT( XN2* XN2+ YN2* YN2+ ZN2* ZN2) >*/
  21694.     d__1 = xn2 * xn2 + yn2 * yn2;
  21695.     xst = sqrt(d__1 + zn2 * zn2);
  21696. /*<       SALPN=1./(3.*( XA+ XST)) >*/
  21697.     salpn = 1. / ((xa + xst) * 3.);
  21698. /*<       X( MI)=( XA*( X1+ X2+ X3)+ XST*( X1+ X3+ X4))* SALPN >*/
  21699.     d__1 = *x1 + *x2;
  21700.     d__2 = *x1 + *x3;
  21701.     data_1.x[mi - 1] = (xa * (d__1 + *x3) + xst * (d__2 + *x4)) * salpn;
  21702. /*<       Y( MI)=( XA*( Y1+ Y2+ Y3)+ XST*( Y1+ Y3+ Y4))* SALPN >*/
  21703.     d__1 = *y1 + *y2;
  21704.     d__2 = *y1 + *y3;
  21705.     data_1.y[mi - 1] = (xa * (d__1 + *y3) + xst * (d__2 + *y4)) * salpn;
  21706. /*<       Z( MI)=( XA*( Z1+ Z2+ Z3)+ XST*( Z1+ Z3+ Z4))* SALPN >*/
  21707.     d__1 = *z1 + *z2;
  21708.     d__2 = *z1 + *z3;
  21709.     data_1.z[mi - 1] = (xa * (d__1 + *z3) + xst * (d__2 + *z4)) * salpn;
  21710. /*<       BI( MI)=.5*( XA+ XST) >*/
  21711.     data_1.bi[mi - 1] = (xa + xst) * .5;
  21712. /*<       S1X=( XNV* XN2+ YNV* YN2+ ZNV* ZN2)/ XST >*/
  21713.     d__1 = xnv * xn2 + ynv * yn2;
  21714.     s1x = (d__1 + znv * zn2) / xst;
  21715. /*<       IF( S1X.GT.0.9998) GOTO 6 >*/
  21716.     if (s1x > .9998) {
  21717.     goto L6;
  21718.     }
  21719. /*<       WRITE( 6,14)  >*/
  21720.     s_wsfe(&io___1664);
  21721.     e_wsfe();
  21722. /*<       STOP >*/
  21723.     s_stop("", 0L);
  21724. /*<     6 T2X( MI)= YNV* T1Z( MI)- ZNV* T1Y( MI) >*/
  21725. L6:
  21726.     t2x[mi - 1] = ynv * t1z[mi - 1] - znv * t1y[mi - 1];
  21727. /*<       T2Y( MI)= ZNV* T1X( MI)- XNV* T1Z( MI) >*/
  21728.     t2y[mi - 1] = znv * t1x[mi - 1] - xnv * t1z[mi - 1];
  21729. /*<       T2Z( MI)= XNV* T1Y( MI)- YNV* T1X( MI) >*/
  21730.     t2z[mi - 1] = xnv * t1y[mi - 1] - ynv * t1x[mi - 1];
  21731. /*<       SALP( MI)=1. >*/
  21732.     angl_1.salp[mi - 1] = 1.;
  21733. /*<       IF( NX.EQ.0) GOTO 8 >*/
  21734.     if (*nx == 0) {
  21735.     goto L8;
  21736.     }
  21737. /*<       M= M+ NX* NY-1 >*/
  21738.     data_1.m = data_1.m + *nx * *ny - 1;
  21739. /*<       XN2= X( MI)- S1X- S2X >*/
  21740.     xn2 = data_1.x[mi - 1] - s1x - s2x;
  21741. /*<       YN2= Y( MI)- S1Y- S2Y >*/
  21742.     yn2 = data_1.y[mi - 1] - s1y - s2y;
  21743. /*<       ZN2= Z( MI)- S1Z- S2Z >*/
  21744.     zn2 = data_1.z[mi - 1] - s1z - s2z;
  21745. /*<       XS= T1X( MI) >*/
  21746.     xs = t1x[mi - 1];
  21747. /*<       YS= T1Y( MI) >*/
  21748.     ys = t1y[mi - 1];
  21749. /*<       ZS= T1Z( MI) >*/
  21750.     zs = t1z[mi - 1];
  21751. /*<       XT= T2X( MI) >*/
  21752.     xt = t2x[mi - 1];
  21753. /*<       YT= T2Y( MI) >*/
  21754.     yt = t2y[mi - 1];
  21755. /*<       ZT= T2Z( MI) >*/
  21756.     zt = t2z[mi - 1];
  21757. /*<       MI= MI+1 >*/
  21758.     ++mi;
  21759. /*<       DO 7  IY=1, NY >*/
  21760.     i__1 = *ny;
  21761.     for (iy = 1; iy <= i__1; ++iy) {
  21762. /*<       XN2= XN2+ S2X >*/
  21763.     xn2 += s2x;
  21764. /*<       YN2= YN2+ S2Y >*/
  21765.     yn2 += s2y;
  21766. /*<       ZN2= ZN2+ S2Z >*/
  21767.     zn2 += s2z;
  21768. /*<       DO 7  IX=1, NX >*/
  21769.     i__2 = *nx;
  21770.     for (ix = 1; ix <= i__2; ++ix) {
  21771. /*<       XST= IX >*/
  21772.         xst = (doublereal) ix;
  21773. /*<       MI= MI-1 >*/
  21774.         --mi;
  21775. /*<       X( MI)= XN2+ XST* S1X >*/
  21776.         data_1.x[mi - 1] = xn2 + xst * s1x;
  21777. /*<       Y( MI)= YN2+ XST* S1Y >*/
  21778.         data_1.y[mi - 1] = yn2 + xst * s1y;
  21779. /*<       Z( MI)= ZN2+ XST* S1Z >*/
  21780.         data_1.z[mi - 1] = zn2 + xst * s1z;
  21781. /*<       BI( MI)= XA >*/
  21782.         data_1.bi[mi - 1] = xa;
  21783. /*<       SALP( MI)=1. >*/
  21784.         angl_1.salp[mi - 1] = 1.;
  21785. /*<       T1X( MI)= XS >*/
  21786.         t1x[mi - 1] = xs;
  21787. /*<       T1Y( MI)= YS >*/
  21788.         t1y[mi - 1] = ys;
  21789. /*<       T1Z( MI)= ZS >*/
  21790.         t1z[mi - 1] = zs;
  21791. /*<       T2X( MI)= XT >*/
  21792.         t2x[mi - 1] = xt;
  21793. /*<       T2Y( MI)= YT >*/
  21794.         t2y[mi - 1] = yt;
  21795. /*<     7 T2Z( MI)= ZT >*/
  21796. /* L7: */
  21797.         t2z[mi - 1] = zt;
  21798.     }
  21799.     }
  21800. /*<     8 IPSYM=0 >*/
  21801. L8:
  21802.     data_1.ipsym = 0;
  21803. /*<       NP= N >*/
  21804.     data_1.np = data_1.n;
  21805. /*<       MP= M >*/
  21806.     data_1.mp = data_1.m;
  21807. /*     DIVIDE PATCH FOR WIRE CONNECTION */
  21808. /*<       RETURN >*/
  21809.     return 0;
  21810. /*<    >*/
  21811.  
  21812. L_subph:
  21813. /*<       IF( NY.GT.0) GOTO 10 >*/
  21814.     if (*ny > 0) {
  21815.     goto L10;
  21816.     }
  21817. /*<       IF( NX.EQ. M) GOTO 10 >*/
  21818.     if (*nx == data_1.m) {
  21819.     goto L10;
  21820.     }
  21821. /*<       NXP= NX+1 >*/
  21822.     nxp = *nx + 1;
  21823. /*<       IX= LD- M >*/
  21824.     ix = data_1.ld - data_1.m;
  21825. /*<       DO 9  IY= NXP, M >*/
  21826.     i__2 = data_1.m;
  21827.     for (iy = nxp; iy <= i__2; ++iy) {
  21828. /*<       IX= IX+1 >*/
  21829.     ++ix;
  21830. /*<       NYP= IX-3 >*/
  21831.     nyp = ix - 3;
  21832. /*<       X( NYP)= X( IX) >*/
  21833.     data_1.x[nyp - 1] = data_1.x[ix - 1];
  21834. /*<       Y( NYP)= Y( IX) >*/
  21835.     data_1.y[nyp - 1] = data_1.y[ix - 1];
  21836. /*<       Z( NYP)= Z( IX) >*/
  21837.     data_1.z[nyp - 1] = data_1.z[ix - 1];
  21838. /*<       BI( NYP)= BI( IX) >*/
  21839.     data_1.bi[nyp - 1] = data_1.bi[ix - 1];
  21840. /*<       SALP( NYP)= SALP( IX) >*/
  21841.     angl_1.salp[nyp - 1] = angl_1.salp[ix - 1];
  21842. /*<       T1X( NYP)= T1X( IX) >*/
  21843.     t1x[nyp - 1] = t1x[ix - 1];
  21844. /*<       T1Y( NYP)= T1Y( IX) >*/
  21845.     t1y[nyp - 1] = t1y[ix - 1];
  21846. /*<       T1Z( NYP)= T1Z( IX) >*/
  21847.     t1z[nyp - 1] = t1z[ix - 1];
  21848. /*<       T2X( NYP)= T2X( IX) >*/
  21849.     t2x[nyp - 1] = t2x[ix - 1];
  21850. /*<       T2Y( NYP)= T2Y( IX) >*/
  21851.     t2y[nyp - 1] = t2y[ix - 1];
  21852. /*<     9 T2Z( NYP)= T2Z( IX) >*/
  21853. /* L9: */
  21854.     t2z[nyp - 1] = t2z[ix - 1];
  21855.     }
  21856. /*<    10 MI= LD+1- NX >*/
  21857. L10:
  21858.     mi = data_1.ld + 1 - *nx;
  21859. /*<       XS= X( MI) >*/
  21860.     xs = data_1.x[mi - 1];
  21861. /*<       YS= Y( MI) >*/
  21862.     ys = data_1.y[mi - 1];
  21863. /*<       ZS= Z( MI) >*/
  21864.     zs = data_1.z[mi - 1];
  21865. /*<       XA= BI( MI)*.25 >*/
  21866.     xa = data_1.bi[mi - 1] * .25;
  21867. /*<       XST= SQRT( XA)*.5 >*/
  21868.     xst = sqrt(xa) * .5;
  21869. /*<       S1X= T1X( MI) >*/
  21870.     s1x = t1x[mi - 1];
  21871. /*<       S1Y= T1Y( MI) >*/
  21872.     s1y = t1y[mi - 1];
  21873. /*<       S1Z= T1Z( MI) >*/
  21874.     s1z = t1z[mi - 1];
  21875. /*<       S2X= T2X( MI) >*/
  21876.     s2x = t2x[mi - 1];
  21877. /*<       S2Y= T2Y( MI) >*/
  21878.     s2y = t2y[mi - 1];
  21879. /*<       S2Z= T2Z( MI) >*/
  21880.     s2z = t2z[mi - 1];
  21881. /*<       SALN= SALP( MI) >*/
  21882.     saln = angl_1.salp[mi - 1];
  21883. /*<       XT= XST >*/
  21884.     xt = xst;
  21885. /*<       YT= XST >*/
  21886.     yt = xst;
  21887. /*<       IF( NY.GT.0) GOTO 11 >*/
  21888.     if (*ny > 0) {
  21889.     goto L11;
  21890.     }
  21891. /*<       MIA= MI >*/
  21892.     mia = mi;
  21893. /*<       GOTO 12 >*/
  21894.     goto L12;
  21895. /*<    11 M= M+1 >*/
  21896. L11:
  21897.     ++data_1.m;
  21898. /*<       MP= MP+1 >*/
  21899.     ++data_1.mp;
  21900. /*<       MIA= LD+1- M >*/
  21901.     mia = data_1.ld + 1 - data_1.m;
  21902. /*<    12 DO 13  IX=1,4 >*/
  21903. L12:
  21904.     for (ix = 1; ix <= 4; ++ix) {
  21905. /*<       X( MIA)= XS+ XT* S1X+ YT* S2X >*/
  21906.     d__1 = xs + xt * s1x;
  21907.     data_1.x[mia - 1] = d__1 + yt * s2x;
  21908. /*<       Y( MIA)= YS+ XT* S1Y+ YT* S2Y >*/
  21909.     d__1 = ys + xt * s1y;
  21910.     data_1.y[mia - 1] = d__1 + yt * s2y;
  21911. /*<       Z( MIA)= ZS+ XT* S1Z+ YT* S2Z >*/
  21912.     d__1 = zs + xt * s1z;
  21913.     data_1.z[mia - 1] = d__1 + yt * s2z;
  21914. /*<       BI( MIA)= XA >*/
  21915.     data_1.bi[mia - 1] = xa;
  21916. /*<       T1X( MIA)= S1X >*/
  21917.     t1x[mia - 1] = s1x;
  21918. /*<       T1Y( MIA)= S1Y >*/
  21919.     t1y[mia - 1] = s1y;
  21920. /*<       T1Z( MIA)= S1Z >*/
  21921.     t1z[mia - 1] = s1z;
  21922. /*<       T2X( MIA)= S2X >*/
  21923.     t2x[mia - 1] = s2x;
  21924. /*<       T2Y( MIA)= S2Y >*/
  21925.     t2y[mia - 1] = s2y;
  21926. /*<       T2Z( MIA)= S2Z >*/
  21927.     t2z[mia - 1] = s2z;
  21928. /*<       SALP( MIA)= SALN >*/
  21929.     angl_1.salp[mia - 1] = saln;
  21930. /*<       IF( IX.EQ.2) YT=- YT >*/
  21931.     if (ix == 2) {
  21932.         yt = -yt;
  21933.     }
  21934. /*<       IF( IX.EQ.1.OR. IX.EQ.3) XT=- XT >*/
  21935.     if (ix == 1 || ix == 3) {
  21936.         xt = -xt;
  21937.     }
  21938. /*<       MIA= MIA-1 >*/
  21939.     --mia;
  21940. /*<    13 CONTINUE >*/
  21941. /* L13: */
  21942.     }
  21943. /*<       M= M+3 >*/
  21944.     data_1.m += 3;
  21945. /*<       IF( NX.LE. MP) MP= MP+3 >*/
  21946.     if (*nx <= data_1.mp) {
  21947.     data_1.mp += 3;
  21948.     }
  21949. /*<       IF( NY.GT.0) Z( MI)=10000. >*/
  21950.     if (*ny > 0) {
  21951.     data_1.z[mi - 1] = 1e4;
  21952.     }
  21953.  
  21954. /*<       RETURN >*/
  21955.     return 0;
  21956. /*<    >*/
  21957. /*<       END >*/
  21958. } /* patch_ */
  21959.  
  21960. #undef t2z
  21961. #undef t2y
  21962. #undef t2x
  21963. #undef t1z
  21964. #undef t1y
  21965. #undef t1x
  21966.  
  21967.  
  21968. /* Subroutine */ int patch_(nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, 
  21969.     y4, z4)
  21970. integer *nx, *ny;
  21971. doublereal *x1, *y1, *z1, *x2, *y2, *z2, *x3, *y3, *z3, *x4, *y4, *z4;
  21972. {
  21973.     return patch_0_(0, nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
  21974.         ;
  21975.     }
  21976.  
  21977. /* Subroutine */ int subph_(nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, 
  21978.     y4, z4)
  21979. integer *nx, *ny;
  21980. doublereal *x1, *y1, *z1, *x2, *y2, *z2, *x3, *y3, *z3, *x4, *y4, *z4;
  21981. {
  21982.     return patch_0_(1, nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
  21983.         ;
  21984.     }
  21985.  
  21986. /* *** */
  21987. /*     DOUBLE PRECISION 6/4/85 */
  21988.  
  21989. /*<       SUBROUTINE PCINT( XI, YI, ZI, CABI, SABI, SALPI, E) >*/
  21990. /* Subroutine */ int pcint_(xi, yi, zi, cabi, sabi, salpi, e)
  21991. doublereal *xi, *yi, *zi, *cabi, *sabi, *salpi;
  21992. doublecomplex *e;
  21993. {
  21994.     /* Initialized data */
  21995.  
  21996.     static doublereal tpi = 6.283185308;
  21997.     static integer nint = 10;
  21998.  
  21999.     /* System generated locals */
  22000.     integer i__1, i__2;
  22001.     doublereal d__1;
  22002.     doublecomplex z__1, z__2, z__3, z__4, z__5;
  22003.  
  22004.     /* Builtin functions */
  22005.     double sqrt();
  22006.  
  22007.     /* Local variables */
  22008.     static doublereal fcon, gcon, d;
  22009.     extern /* Subroutine */ int unere_();
  22010.     static doublecomplex e1, e2, e3, e4, e5, e6, e7, e8, e9;
  22011.     static integer i1, i2;
  22012.     static doublereal g1, g2, g3, s1, s2, g4, f2, f1, da, ds, xs, s2x, xxj, 
  22013.         xyj, xzj, xss, yss, zss;
  22014. #define t1xj ((doublereal *)&dataj_1 + 5)
  22015. #define t1yj ((doublereal *)&dataj_1 + 6)
  22016. #define t1zj ((doublereal *)&dataj_1 + 7)
  22017. #define t2xj ((doublereal *)&dataj_1 + 1)
  22018. #define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
  22019. #define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
  22020.  
  22021. /* *** */
  22022. /*     INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT */
  22023. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  22024. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  22025. /*<    >*/
  22026. /*<    >*/
  22027. /*<       DIMENSION  E(9) >*/
  22028. /*<    >*/
  22029. /*<       DATA   TPI/6.283185308D+0/, NINT/10/ >*/
  22030.     /* Parameter adjustments */
  22031.     --e;
  22032.  
  22033.     /* Function Body */
  22034. /*<       D= SQRT( S)*.5 >*/
  22035.     d = sqrt(dataj_1.s) * .5;
  22036. /*<       DS=4.* D/ DFLOAT( NINT) >*/
  22037.     ds = d * 4. / (doublereal) nint;
  22038. /*<       DA= DS* DS >*/
  22039.     da = ds * ds;
  22040. /*<       GCON=1./ S >*/
  22041.     gcon = 1. / dataj_1.s;
  22042. /*<       FCON=1./(2.* TPI* D) >*/
  22043.     d__1 = tpi * 2.;
  22044.     fcon = 1. / (d__1 * d);
  22045. /*<       XXJ= XJ >*/
  22046.     xxj = dataj_1.xj;
  22047. /*<       XYJ= YJ >*/
  22048.     xyj = dataj_1.yj;
  22049. /*<       XZJ= ZJ >*/
  22050.     xzj = dataj_1.zj;
  22051. /*<       XS= S >*/
  22052.     xs = dataj_1.s;
  22053. /*<       S= DA >*/
  22054.     dataj_1.s = da;
  22055. /*<       S1= D+ DS*.5 >*/
  22056.     s1 = d + ds * .5;
  22057. /*<       XSS= XJ+ S1*( T1XJ+ T2XJ) >*/
  22058.     xss = dataj_1.xj + s1 * (*t1xj + *t2xj);
  22059. /*<       YSS= YJ+ S1*( T1YJ+ T2YJ) >*/
  22060.     yss = dataj_1.yj + s1 * (*t1yj + *t2yj);
  22061. /*<       ZSS= ZJ+ S1*( T1ZJ+ T2ZJ) >*/
  22062.     zss = dataj_1.zj + s1 * (*t1zj + *t2zj);
  22063. /*<       S1= S1+ D >*/
  22064.     s1 += d;
  22065. /*<       S2X= S1 >*/
  22066.     s2x = s1;
  22067. /*<       E1=(0.,0.) >*/
  22068.     e1.r = 0., e1.i = 0.;
  22069. /*<       E2=(0.,0.) >*/
  22070.     e2.r = 0., e2.i = 0.;
  22071. /*<       E3=(0.,0.) >*/
  22072.     e3.r = 0., e3.i = 0.;
  22073. /*<       E4=(0.,0.) >*/
  22074.     e4.r = 0., e4.i = 0.;
  22075. /*<       E5=(0.,0.) >*/
  22076.     e5.r = 0., e5.i = 0.;
  22077. /*<       E6=(0.,0.) >*/
  22078.     e6.r = 0., e6.i = 0.;
  22079. /*<       E7=(0.,0.) >*/
  22080.     e7.r = 0., e7.i = 0.;
  22081. /*<       E8=(0.,0.) >*/
  22082.     e8.r = 0., e8.i = 0.;
  22083. /*<       E9=(0.,0.) >*/
  22084.     e9.r = 0., e9.i = 0.;
  22085. /*<       DO 1  I1=1, NINT >*/
  22086.     i__1 = nint;
  22087.     for (i1 = 1; i1 <= i__1; ++i1) {
  22088. /*<       S1= S1- DS >*/
  22089.     s1 -= ds;
  22090. /*<       S2= S2X >*/
  22091.     s2 = s2x;
  22092. /*<       XSS= XSS- DS* T1XJ >*/
  22093.     xss -= ds * *t1xj;
  22094. /*<       YSS= YSS- DS* T1YJ >*/
  22095.     yss -= ds * *t1yj;
  22096. /*<       ZSS= ZSS- DS* T1ZJ >*/
  22097.     zss -= ds * *t1zj;
  22098. /*<       XJ= XSS >*/
  22099.     dataj_1.xj = xss;
  22100. /*<       YJ= YSS >*/
  22101.     dataj_1.yj = yss;
  22102. /*<       ZJ= ZSS >*/
  22103.     dataj_1.zj = zss;
  22104. /*<       DO 1  I2=1, NINT >*/
  22105.     i__2 = nint;
  22106.     for (i2 = 1; i2 <= i__2; ++i2) {
  22107. /*<       S2= S2- DS >*/
  22108.         s2 -= ds;
  22109. /*<       XJ= XJ- DS* T2XJ >*/
  22110.         dataj_1.xj -= ds * *t2xj;
  22111. /*<       YJ= YJ- DS* T2YJ >*/
  22112.         dataj_1.yj -= ds * *t2yj;
  22113. /*<       ZJ= ZJ- DS* T2ZJ >*/
  22114.         dataj_1.zj -= ds * *t2zj;
  22115. /*<       CALL UNERE( XI, YI, ZI) >*/
  22116.         unere_(xi, yi, zi);
  22117. /*<       EXK= EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
  22118.         z__3.r = *cabi * dataj_1.exk.r, z__3.i = *cabi * dataj_1.exk.i;
  22119.         z__4.r = *sabi * dataj_1.eyk.r, z__4.i = *sabi * dataj_1.eyk.i;
  22120.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22121.         z__5.r = *salpi * dataj_1.ezk.r, z__5.i = *salpi * dataj_1.ezk.i;
  22122.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22123.         dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  22124. /*<       EXS= EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
  22125.         z__3.r = *cabi * dataj_1.exs.r, z__3.i = *cabi * dataj_1.exs.i;
  22126.         z__4.r = *sabi * dataj_1.eys.r, z__4.i = *sabi * dataj_1.eys.i;
  22127.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22128.         z__5.r = *salpi * dataj_1.ezs.r, z__5.i = *salpi * dataj_1.ezs.i;
  22129.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22130.         dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  22131. /*<       G1=( D+ S1)*( D+ S2)* GCON >*/
  22132.         d__1 = (d + s1) * (d + s2);
  22133.         g1 = d__1 * gcon;
  22134. /*<       G2=( D- S1)*( D+ S2)* GCON >*/
  22135.         d__1 = (d - s1) * (d + s2);
  22136.         g2 = d__1 * gcon;
  22137. /*<       G3=( D- S1)*( D- S2)* GCON >*/
  22138.         d__1 = (d - s1) * (d - s2);
  22139.         g3 = d__1 * gcon;
  22140. /*<       G4=( D+ S1)*( D- S2)* GCON >*/
  22141.         d__1 = (d + s1) * (d - s2);
  22142.         g4 = d__1 * gcon;
  22143. /*<       F2=( S1* S1+ S2* S2)* TPI >*/
  22144.         f2 = (s1 * s1 + s2 * s2) * tpi;
  22145. /*<       F1= S1/ F2-( G1- G2- G3+ G4)* FCON >*/
  22146.         f1 = s1 / f2 - (g1 - g2 - g3 + g4) * fcon;
  22147. /*<       F2= S2/ F2-( G1+ G2- G3- G4)* FCON >*/
  22148.         f2 = s2 / f2 - (g1 + g2 - g3 - g4) * fcon;
  22149. /*<       E1= E1+ EXK* G1 >*/
  22150.         z__2.r = g1 * dataj_1.exk.r, z__2.i = g1 * dataj_1.exk.i;
  22151.         z__1.r = e1.r + z__2.r, z__1.i = e1.i + z__2.i;
  22152.         e1.r = z__1.r, e1.i = z__1.i;
  22153. /*<       E2= E2+ EXK* G2 >*/
  22154.         z__2.r = g2 * dataj_1.exk.r, z__2.i = g2 * dataj_1.exk.i;
  22155.         z__1.r = e2.r + z__2.r, z__1.i = e2.i + z__2.i;
  22156.         e2.r = z__1.r, e2.i = z__1.i;
  22157. /*<       E3= E3+ EXK* G3 >*/
  22158.         z__2.r = g3 * dataj_1.exk.r, z__2.i = g3 * dataj_1.exk.i;
  22159.         z__1.r = e3.r + z__2.r, z__1.i = e3.i + z__2.i;
  22160.         e3.r = z__1.r, e3.i = z__1.i;
  22161. /*<       E4= E4+ EXK* G4 >*/
  22162.         z__2.r = g4 * dataj_1.exk.r, z__2.i = g4 * dataj_1.exk.i;
  22163.         z__1.r = e4.r + z__2.r, z__1.i = e4.i + z__2.i;
  22164.         e4.r = z__1.r, e4.i = z__1.i;
  22165. /*<       E5= E5+ EXS* G1 >*/
  22166.         z__2.r = g1 * dataj_1.exs.r, z__2.i = g1 * dataj_1.exs.i;
  22167.         z__1.r = e5.r + z__2.r, z__1.i = e5.i + z__2.i;
  22168.         e5.r = z__1.r, e5.i = z__1.i;
  22169. /*<       E6= E6+ EXS* G2 >*/
  22170.         z__2.r = g2 * dataj_1.exs.r, z__2.i = g2 * dataj_1.exs.i;
  22171.         z__1.r = e6.r + z__2.r, z__1.i = e6.i + z__2.i;
  22172.         e6.r = z__1.r, e6.i = z__1.i;
  22173. /*<       E7= E7+ EXS* G3 >*/
  22174.         z__2.r = g3 * dataj_1.exs.r, z__2.i = g3 * dataj_1.exs.i;
  22175.         z__1.r = e7.r + z__2.r, z__1.i = e7.i + z__2.i;
  22176.         e7.r = z__1.r, e7.i = z__1.i;
  22177. /*<       E8= E8+ EXS* G4 >*/
  22178.         z__2.r = g4 * dataj_1.exs.r, z__2.i = g4 * dataj_1.exs.i;
  22179.         z__1.r = e8.r + z__2.r, z__1.i = e8.i + z__2.i;
  22180.         e8.r = z__1.r, e8.i = z__1.i;
  22181. /*<     1 E9= E9+ EXK* F1+ EXS* F2 >*/
  22182. /* L1: */
  22183.         z__3.r = f1 * dataj_1.exk.r, z__3.i = f1 * dataj_1.exk.i;
  22184.         z__2.r = e9.r + z__3.r, z__2.i = e9.i + z__3.i;
  22185.         z__4.r = f2 * dataj_1.exs.r, z__4.i = f2 * dataj_1.exs.i;
  22186.         z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
  22187.         e9.r = z__1.r, e9.i = z__1.i;
  22188.     }
  22189.     }
  22190. /*<       E(1)= E1 >*/
  22191.     e[1].r = e1.r, e[1].i = e1.i;
  22192. /*<       E(2)= E2 >*/
  22193.     e[2].r = e2.r, e[2].i = e2.i;
  22194. /*<       E(3)= E3 >*/
  22195.     e[3].r = e3.r, e[3].i = e3.i;
  22196. /*<       E(4)= E4 >*/
  22197.     e[4].r = e4.r, e[4].i = e4.i;
  22198. /*<       E(5)= E5 >*/
  22199.     e[5].r = e5.r, e[5].i = e5.i;
  22200. /*<       E(6)= E6 >*/
  22201.     e[6].r = e6.r, e[6].i = e6.i;
  22202. /*<       E(7)= E7 >*/
  22203.     e[7].r = e7.r, e[7].i = e7.i;
  22204. /*<       E(8)= E8 >*/
  22205.     e[8].r = e8.r, e[8].i = e8.i;
  22206. /*<       E(9)= E9 >*/
  22207.     e[9].r = e9.r, e[9].i = e9.i;
  22208. /*<       XJ= XXJ >*/
  22209.     dataj_1.xj = xxj;
  22210. /*<       YJ= XYJ >*/
  22211.     dataj_1.yj = xyj;
  22212. /*<       ZJ= XZJ >*/
  22213.     dataj_1.zj = xzj;
  22214. /*<       S= XS >*/
  22215.     dataj_1.s = xs;
  22216. /*<       RETURN >*/
  22217.     return 0;
  22218. /*<       END >*/
  22219. } /* pcint_ */
  22220.  
  22221. #undef t2zj
  22222. #undef t2yj
  22223. #undef t2xj
  22224. #undef t1zj
  22225. #undef t1yj
  22226. #undef t1xj
  22227.  
  22228.  
  22229. /* *** */
  22230. /*     DOUBLE PRECISION 6/4/85 */
  22231.  
  22232. /*<    >*/
  22233. /* Subroutine */ int prnt_(in1, in2, in3, fl1, fl2, fl3, fl4, fl5, fl6, ia, 
  22234.     ichar)
  22235. integer *in1, *in2, *in3;
  22236. doublereal *fl1, *fl2, *fl3, *fl4, *fl5, *fl6;
  22237. integer *ia, *ichar;
  22238. {
  22239.     /* Initialized data */
  22240.  
  22241.     static char iform[6*8+1] = "(/3X, I5,   5X,   A5,   E13.4,13X,  3X,   5A\
  22242. 4)  ";
  22243.     static struct {
  22244.     char e_1[4];
  22245.     integer e_2;
  22246.     } equiv_1732 = { {' ', 'A', 'L', 'L'}, 0 };
  22247.  
  22248. #define hall (*(integer *)&equiv_1732)
  22249.  
  22250.  
  22251.     /* System generated locals */
  22252.     integer i__1, i__2, i__3;
  22253.     doublereal d__1;
  22254.  
  22255.     /* Builtin functions */
  22256.     /* Subroutine */ int s_copy();
  22257.     integer s_wsfe(), do_fio(), e_wsfe();
  22258.  
  22259.     /* Local variables */
  22260.     static char ivar[6*13];
  22261.     static integer nflt, nint, i, j, k, l, i1;
  22262.     static doublereal fl[6];
  22263.     static integer in[3];
  22264.     static doublereal flt[6];
  22265.     static integer int_[3];
  22266.  
  22267.     /* Fortran I/O blocks */
  22268.     static cilist io___1729 = { 0, 6, 0, ivar, 0 };
  22269.  
  22270.  
  22271. /* *** */
  22272.  
  22273. /*     PRNT SETS UP THE PRINT FORMATS FOR IMPEDANCE LOADING */
  22274.  
  22275. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  22276. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  22277. /*     REAL  IFORM, IVAR */
  22278. /*<       CHARACTER*6 IFORM(8),IVAR(13) >*/
  22279. /*<       DIMENSION IA(1),IN(3),INT(3),FL(6),FLT(6) >*/
  22280. /*<       INTEGER  HALL >*/
  22281.  
  22282. /*     NUMBER OF CHARACTERS PER COMPUTER WORD IS NCPW */
  22283.  
  22284. /*<    >*/
  22285.     /* Parameter adjustments */
  22286.     --ia;
  22287.  
  22288.     /* Function Body */
  22289. /*<       DATA   HALL/4H ALL/ >*/
  22290. /*<       IN(1)= IN1 >*/
  22291.     in[0] = *in1;
  22292. /*<       IN(2)= IN2 >*/
  22293.     in[1] = *in2;
  22294. /*<       IN(3)= IN3 >*/
  22295.     in[2] = *in3;
  22296. /*<       FL(1)= FL1 >*/
  22297.     fl[0] = *fl1;
  22298. /*<       FL(2)= FL2 >*/
  22299.     fl[1] = *fl2;
  22300. /*<       FL(3)= FL3 >*/
  22301.     fl[2] = *fl3;
  22302. /*<       FL(4)= FL4 >*/
  22303.     fl[3] = *fl4;
  22304. /*<       FL(5)= FL5 >*/
  22305.     fl[4] = *fl5;
  22306.  
  22307. /*     INTEGER FORMAT */
  22308.  
  22309. /*<       FL(6)= FL6 >*/
  22310.     fl[5] = *fl6;
  22311. /*<       NINT=0 >*/
  22312.     nint = 0;
  22313. /*<       IVAR(1)= IFORM(1) >*/
  22314.     s_copy(ivar, iform, 6L, 6L);
  22315. /*<       K=1 >*/
  22316.     k = 1;
  22317. /*<       I1=1 >*/
  22318.     i1 = 1;
  22319. /*<       IF(.NOT.( IN1.EQ.0.AND. IN2.EQ.0.AND. IN3.EQ.0)) GOTO 1 >*/
  22320.     if (! (*in1 == 0 && *in2 == 0 && *in3 == 0)) {
  22321.     goto L1;
  22322.     }
  22323. /*<       INT(1)= HALL >*/
  22324.     int_[0] = hall;
  22325. /*<       NINT=1 >*/
  22326.     nint = 1;
  22327. /*<       I1=2 >*/
  22328.     i1 = 2;
  22329. /*<       K= K+1 >*/
  22330.     ++k;
  22331. /*<       IVAR( K)= IFORM(4) >*/
  22332.     s_copy(ivar + (k - 1) * 6, iform + 18, 6L, 6L);
  22333. /*<     1 DO 3  I= I1,3 >*/
  22334. L1:
  22335.     for (i = i1; i <= 3; ++i) {
  22336. /*<       K= K+1 >*/
  22337.     ++k;
  22338. /*<       IF( IN( I).EQ.0) GOTO 2 >*/
  22339.     if (in[i - 1] == 0) {
  22340.         goto L2;
  22341.     }
  22342. /*<       NINT= NINT+1 >*/
  22343.     ++nint;
  22344. /*<       INT( NINT)= IN( I) >*/
  22345.     int_[nint - 1] = in[i - 1];
  22346. /*<       IVAR( K)= IFORM(2) >*/
  22347.     s_copy(ivar + (k - 1) * 6, iform + 6, 6L, 6L);
  22348. /*<       GOTO 3 >*/
  22349.     goto L3;
  22350. /*<     2 IVAR( K)= IFORM(3) >*/
  22351. L2:
  22352.     s_copy(ivar + (k - 1) * 6, iform + 12, 6L, 6L);
  22353. /*<     3 CONTINUE >*/
  22354. L3:
  22355.     ;
  22356.     }
  22357. /*<       K= K+1 >*/
  22358.     ++k;
  22359.  
  22360. /*     DFLOATING POINT FORMAT */
  22361.  
  22362. /*<       IVAR( K)= IFORM(7) >*/
  22363.     s_copy(ivar + (k - 1) * 6, iform + 36, 6L, 6L);
  22364. /*<       NFLT=0 >*/
  22365.     nflt = 0;
  22366. /*<       DO 5  I=1,6 >*/
  22367.     for (i = 1; i <= 6; ++i) {
  22368. /*<       K= K+1 >*/
  22369.     ++k;
  22370. /*<       IF( ABS( FL( I)).LT.1.D-20) GOTO 4 >*/
  22371.     if ((d__1 = fl[i - 1], abs(d__1)) < 1e-20) {
  22372.         goto L4;
  22373.     }
  22374. /*<       NFLT= NFLT+1 >*/
  22375.     ++nflt;
  22376. /*<       FLT( NFLT)= FL( I) >*/
  22377.     flt[nflt - 1] = fl[i - 1];
  22378. /*<       IVAR( K)= IFORM(5) >*/
  22379.     s_copy(ivar + (k - 1) * 6, iform + 24, 6L, 6L);
  22380. /*<       GOTO 5 >*/
  22381.     goto L5;
  22382. /*<     4 IVAR( K)= IFORM(6) >*/
  22383. L4:
  22384.     s_copy(ivar + (k - 1) * 6, iform + 30, 6L, 6L);
  22385. /*<     5 CONTINUE >*/
  22386. L5:
  22387.     ;
  22388.     }
  22389. /*<       K= K+1 >*/
  22390.     ++k;
  22391. /*<       IVAR( K)= IFORM(7) >*/
  22392.     s_copy(ivar + (k - 1) * 6, iform + 36, 6L, 6L);
  22393. /*<       K= K+1 >*/
  22394.     ++k;
  22395. /*<       IVAR( K)= IFORM(8) >*/
  22396.     s_copy(ivar + (k - 1) * 6, iform + 42, 6L, 6L);
  22397. /*<    >*/
  22398.     s_wsfe(&io___1729);
  22399.     i__1 = nint;
  22400.     for (i = 1; i <= i__1; ++i) {
  22401.     do_fio(&c__1, (char *)&int_[i - 1], (ftnlen)sizeof(integer));
  22402.     }
  22403.     i__2 = nflt;
  22404.     for (j = 1; j <= i__2; ++j) {
  22405.     do_fio(&c__1, (char *)&flt[j - 1], (ftnlen)sizeof(doublereal));
  22406.     }
  22407.     i__3 = *ichar;
  22408.     for (l = 1; l <= i__3; ++l) {
  22409.     do_fio(&c__1, (char *)&ia[l], (ftnlen)sizeof(integer));
  22410.     }
  22411.     e_wsfe();
  22412. /*<       RETURN >*/
  22413.     return 0;
  22414. /*<       END >*/
  22415. } /* prnt_ */
  22416.  
  22417. #undef hall
  22418.  
  22419.  
  22420. /* *** */
  22421. /*     DOUBLE PRECISION 6/4/85 */
  22422.  
  22423. /*<       SUBROUTINE QDSRC( IS, V, E) >*/
  22424. /* Subroutine */ int qdsrc_(is, v, e)
  22425. integer *is;
  22426. doublecomplex *v, *e;
  22427. {
  22428.     /* Initialized data */
  22429.  
  22430.     static doublereal tp = 6.283185308;
  22431.     static struct {
  22432.     doublereal e_1[3];
  22433.     } equiv_0 = { 0., -.01666666667, 0. };
  22434.  
  22435.  
  22436.     /* System generated locals */
  22437.     integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
  22438.     doublereal d__1, d__2;
  22439.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
  22440.  
  22441.     /* Builtin functions */
  22442.     double log(), cos(), sin();
  22443.  
  22444.     /* Local variables */
  22445.     extern /* Subroutine */ int efld_();
  22446.     static doublereal sabi;
  22447. #define ccjx ((doublereal *)&equiv_0)
  22448.     static doublecomplex curd;
  22449.     static integer i, j;
  22450.     extern /* Subroutine */ int hsfld_();
  22451.     static doublereal salpi;
  22452.     static integer i1;
  22453.     static doublereal ai;
  22454.     static integer ij;
  22455.     static doublereal xi;
  22456.     static integer jx;
  22457.     static doublereal yi, zi, tx, ty, tz;
  22458. #define t1x ((doublereal *)&data_1 + 1800)
  22459. #define t1y ((doublereal *)&data_1 + 3000)
  22460. #define t1z ((doublereal *)&data_1 + 3600)
  22461. #define t2x ((doublereal *)&data_1 + 4201)
  22462. #define t2y ((doublereal *)&data_1 + 4601)
  22463. #define t2z ((doublereal *)&data_1 + 5001)
  22464. #define cab ((doublereal *)&data_1 + 3000)
  22465. #define ccj ((doublecomplex *)&equiv_0)
  22466. #define sab ((doublereal *)&data_1 + 3600)
  22467.     static doublecomplex etc;
  22468.     extern /* Subroutine */ int tbf_();
  22469.     static doublecomplex etk, ets;
  22470.     static integer ipr;
  22471.     static doublereal cabi;
  22472.  
  22473. /* *** */
  22474. /*     FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE 
  22475. */
  22476. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  22477. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  22478. /*<    >*/
  22479. /*<    >*/
  22480. /*<    >*/
  22481. /*<    >*/
  22482. /*<    >*/
  22483. /*<       COMMON  /ANGL/ SALP( NM) >*/
  22484. /*<       COMMON  /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
  22485. /*<       DIMENSION  CCJX(2), E(1), CAB(1), SAB(1) >*/
  22486. /*<       DIMENSION  T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
  22487. /*<       EQUIVALENCE(CCJ,CCJX),(CAB,ALP),(SAB,BET) >*/
  22488. /*<    >*/
  22489. /*<       DATA   TP/6.283185308D+0/, CCJX/0.,-.01666666667D+0/ >*/
  22490.     /* Parameter adjustments */
  22491.     --e;
  22492.  
  22493.     /* Function Body */
  22494. /*<       I= ICON1( IS) >*/
  22495.     i = data_1.icon1[*is - 1];
  22496. /*<       ICON1( IS)=0 >*/
  22497.     data_1.icon1[*is - 1] = 0;
  22498. /*<       CALL TBF( IS,0) >*/
  22499.     tbf_(is, &c__0);
  22500. /*<       ICON1( IS)= I >*/
  22501.     data_1.icon1[*is - 1] = i;
  22502. /*<       S= SI( IS)*.5 >*/
  22503.     dataj_1.s = data_1.si[*is - 1] * .5;
  22504. /*<    >*/
  22505.     z__2.r = ccj->r * v->r - ccj->i * v->i, z__2.i = ccj->r * v->i + ccj->i * 
  22506.         v->r;
  22507.     d__2 = (log(dataj_1.s * 2. / data_1.bi[*is - 1]) - 1.) * (segj_1.bx[
  22508.         segj_1.jsno - 1] * cos(tp * dataj_1.s) + segj_1.cx[segj_1.jsno - 
  22509.         1] * sin(tp * dataj_1.s));
  22510.     d__1 = d__2 * data_1.wlam;
  22511.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  22512.     curd.r = z__1.r, curd.i = z__1.i;
  22513. /*<       NQDS= NQDS+1 >*/
  22514.     ++vsorc_1.nqds;
  22515. /*<       VQDS( NQDS)= V >*/
  22516.     i__1 = vsorc_1.nqds - 1;
  22517.     vsorc_1.vqds[i__1].r = v->r, vsorc_1.vqds[i__1].i = v->i;
  22518. /*<       IQDS( NQDS)= IS >*/
  22519.     vsorc_1.iqds[vsorc_1.nqds - 1] = *is;
  22520. /*<       DO 20  JX=1, JSNO >*/
  22521.     i__1 = segj_1.jsno;
  22522.     for (jx = 1; jx <= i__1; ++jx) {
  22523. /*<       J= JCO( JX) >*/
  22524.     j = segj_1.jco[jx - 1];
  22525. /*<       S= SI( J) >*/
  22526.     dataj_1.s = data_1.si[j - 1];
  22527. /*<       B= BI( J) >*/
  22528.     dataj_1.b = data_1.bi[j - 1];
  22529. /*<       XJ= X( J) >*/
  22530.     dataj_1.xj = data_1.x[j - 1];
  22531. /*<       YJ= Y( J) >*/
  22532.     dataj_1.yj = data_1.y[j - 1];
  22533. /*<       ZJ= Z( J) >*/
  22534.     dataj_1.zj = data_1.z[j - 1];
  22535. /*<       CABJ= CAB( J) >*/
  22536.     dataj_1.cabj = cab[j - 1];
  22537. /*<       SABJ= SAB( J) >*/
  22538.     dataj_1.sabj = sab[j - 1];
  22539. /*<       SALPJ= SALP( J) >*/
  22540.     dataj_1.salpj = angl_1.salp[j - 1];
  22541. /*<       IF( IEXK.EQ.0) GOTO 16 >*/
  22542.     if (dataj_1.iexk == 0) {
  22543.         goto L16;
  22544.     }
  22545. /*<       IPR= ICON1( J) >*/
  22546.     ipr = data_1.icon1[j - 1];
  22547. /*<       IF( IPR) 1,6,2 >*/
  22548.     if (ipr < 0) {
  22549.         goto L1;
  22550.     } else if (ipr == 0) {
  22551.         goto L6;
  22552.     } else {
  22553.         goto L2;
  22554.     }
  22555. /*<     1 IPR=- IPR >*/
  22556. L1:
  22557.     ipr = -ipr;
  22558. /*<       IF(- ICON1( IPR).NE. J) GOTO 7 >*/
  22559.     if (-data_1.icon1[ipr - 1] != j) {
  22560.         goto L7;
  22561.     }
  22562. /*<       GOTO 4 >*/
  22563.     goto L4;
  22564. /*<     2 IF( IPR.NE. J) GOTO 3 >*/
  22565. L2:
  22566.     if (ipr != j) {
  22567.         goto L3;
  22568.     }
  22569. /*<       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7 >*/
  22570.     if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) 
  22571.         {
  22572.         goto L7;
  22573.     }
  22574. /*<       GOTO 5 >*/
  22575.     goto L5;
  22576. /*<     3 IF( ICON2( IPR).NE. J) GOTO 7 >*/
  22577. L3:
  22578.     if (data_1.icon2[ipr - 1] != j) {
  22579.         goto L7;
  22580.     }
  22581. /*<     4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
  22582. L4:
  22583.     d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
  22584.     xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
  22585. /*<       IF( XI.LT.0.999999D+0) GOTO 7 >*/
  22586.     if (xi < .999999) {
  22587.         goto L7;
  22588.     }
  22589. /*<       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7 >*/
  22590.     if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
  22591.         goto L7;
  22592.     }
  22593. /*<     5 IND1=0 >*/
  22594. L5:
  22595.     dataj_1.ind1 = 0;
  22596. /*<       GOTO 8 >*/
  22597.     goto L8;
  22598. /*<     6 IND1=1 >*/
  22599. L6:
  22600.     dataj_1.ind1 = 1;
  22601. /*<       GOTO 8 >*/
  22602.     goto L8;
  22603. /*<     7 IND1=2 >*/
  22604. L7:
  22605.     dataj_1.ind1 = 2;
  22606. /*<     8 IPR= ICON2( J) >*/
  22607. L8:
  22608.     ipr = data_1.icon2[j - 1];
  22609. /*<       IF( IPR) 9,14,10 >*/
  22610.     if (ipr < 0) {
  22611.         goto L9;
  22612.     } else if (ipr == 0) {
  22613.         goto L14;
  22614.     } else {
  22615.         goto L10;
  22616.     }
  22617. /*<     9 IPR=- IPR >*/
  22618. L9:
  22619.     ipr = -ipr;
  22620. /*<       IF(- ICON2( IPR).NE. J) GOTO 15 >*/
  22621.     if (-data_1.icon2[ipr - 1] != j) {
  22622.         goto L15;
  22623.     }
  22624. /*<       GOTO 12 >*/
  22625.     goto L12;
  22626. /*<    10 IF( IPR.NE. J) GOTO 11 >*/
  22627. L10:
  22628.     if (ipr != j) {
  22629.         goto L11;
  22630.     }
  22631. /*<       IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15 >*/
  22632.     if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) 
  22633.         {
  22634.         goto L15;
  22635.     }
  22636. /*<       GOTO 13 >*/
  22637.     goto L13;
  22638. /*<    11 IF( ICON1( IPR).NE. J) GOTO 15 >*/
  22639. L11:
  22640.     if (data_1.icon1[ipr - 1] != j) {
  22641.         goto L15;
  22642.     }
  22643. /*<    12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
  22644. L12:
  22645.     d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
  22646.     xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
  22647. /*<       IF( XI.LT.0.999999D+0) GOTO 15 >*/
  22648.     if (xi < .999999) {
  22649.         goto L15;
  22650.     }
  22651. /*<       IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15 >*/
  22652.     if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
  22653.         goto L15;
  22654.     }
  22655. /*<    13 IND2=0 >*/
  22656. L13:
  22657.     dataj_1.ind2 = 0;
  22658. /*<       GOTO 16 >*/
  22659.     goto L16;
  22660. /*<    14 IND2=1 >*/
  22661. L14:
  22662.     dataj_1.ind2 = 1;
  22663. /*<       GOTO 16 >*/
  22664.     goto L16;
  22665. /*<    15 IND2=2 >*/
  22666. L15:
  22667.     dataj_1.ind2 = 2;
  22668. /*<    16 CONTINUE >*/
  22669. L16:
  22670. /*<       DO 17  I=1, N >*/
  22671.     i__2 = data_1.n;
  22672.     for (i = 1; i <= i__2; ++i) {
  22673. /*<       IJ= I- J >*/
  22674.         ij = i - j;
  22675. /*<       XI= X( I) >*/
  22676.         xi = data_1.x[i - 1];
  22677. /*<       YI= Y( I) >*/
  22678.         yi = data_1.y[i - 1];
  22679. /*<       ZI= Z( I) >*/
  22680.         zi = data_1.z[i - 1];
  22681. /*<       AI= BI( I) >*/
  22682.         ai = data_1.bi[i - 1];
  22683. /*<       CALL EFLD( XI, YI, ZI, AI, IJ) >*/
  22684.         efld_(&xi, &yi, &zi, &ai, &ij);
  22685. /*<       CABI= CAB( I) >*/
  22686.         cabi = cab[i - 1];
  22687. /*<       SABI= SAB( I) >*/
  22688.         sabi = sab[i - 1];
  22689. /*<       SALPI= SALP( I) >*/
  22690.         salpi = angl_1.salp[i - 1];
  22691. /*<       ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
  22692.         z__3.r = cabi * dataj_1.exk.r, z__3.i = cabi * dataj_1.exk.i;
  22693.         z__4.r = sabi * dataj_1.eyk.r, z__4.i = sabi * dataj_1.eyk.i;
  22694.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22695.         z__5.r = salpi * dataj_1.ezk.r, z__5.i = salpi * dataj_1.ezk.i;
  22696.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22697.         etk.r = z__1.r, etk.i = z__1.i;
  22698. /*<       ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
  22699.         z__3.r = cabi * dataj_1.exs.r, z__3.i = cabi * dataj_1.exs.i;
  22700.         z__4.r = sabi * dataj_1.eys.r, z__4.i = sabi * dataj_1.eys.i;
  22701.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22702.         z__5.r = salpi * dataj_1.ezs.r, z__5.i = salpi * dataj_1.ezs.i;
  22703.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22704.         ets.r = z__1.r, ets.i = z__1.i;
  22705. /*<       ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI >*/
  22706.         z__3.r = cabi * dataj_1.exc.r, z__3.i = cabi * dataj_1.exc.i;
  22707.         z__4.r = sabi * dataj_1.eyc.r, z__4.i = sabi * dataj_1.eyc.i;
  22708.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22709.         z__5.r = salpi * dataj_1.ezc.r, z__5.i = salpi * dataj_1.ezc.i;
  22710.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22711.         etc.r = z__1.r, etc.i = z__1.i;
  22712. /*<    17 E( I)= E( I)-( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD >*/
  22713. /* L17: */
  22714.         i__3 = i;
  22715.         i__4 = i;
  22716.         i__5 = jx - 1;
  22717.         z__5.r = segj_1.ax[i__5] * etk.r, z__5.i = segj_1.ax[i__5] * 
  22718.             etk.i;
  22719.         i__6 = jx - 1;
  22720.         z__6.r = segj_1.bx[i__6] * ets.r, z__6.i = segj_1.bx[i__6] * 
  22721.             ets.i;
  22722.         z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  22723.         i__7 = jx - 1;
  22724.         z__7.r = segj_1.cx[i__7] * etc.r, z__7.i = segj_1.cx[i__7] * 
  22725.             etc.i;
  22726.         z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
  22727.         z__2.r = z__3.r * curd.r - z__3.i * curd.i, z__2.i = z__3.r * 
  22728.             curd.i + z__3.i * curd.r;
  22729.         z__1.r = e[i__4].r - z__2.r, z__1.i = e[i__4].i - z__2.i;
  22730.         e[i__3].r = z__1.r, e[i__3].i = z__1.i;
  22731.     }
  22732. /*<       IF( M.EQ.0) GOTO 19 >*/
  22733.     if (data_1.m == 0) {
  22734.         goto L19;
  22735.     }
  22736. /*<       IJ= LD+1 >*/
  22737.     ij = data_1.ld + 1;
  22738. /*<       I1= N >*/
  22739.     i1 = data_1.n;
  22740. /*<       DO 18  I=1, M >*/
  22741.     i__3 = data_1.m;
  22742.     for (i = 1; i <= i__3; ++i) {
  22743. /*<       IJ= IJ-1 >*/
  22744.         --ij;
  22745. /*<       XI= X( IJ) >*/
  22746.         xi = data_1.x[ij - 1];
  22747. /*<       YI= Y( IJ) >*/
  22748.         yi = data_1.y[ij - 1];
  22749. /*<       ZI= Z( IJ) >*/
  22750.         zi = data_1.z[ij - 1];
  22751. /*<       CALL HSFLD( XI, YI, ZI,0.) >*/
  22752.         hsfld_(&xi, &yi, &zi, &c_b594);
  22753. /*<       I1= I1+1 >*/
  22754.         ++i1;
  22755. /*<       TX= T2X( IJ) >*/
  22756.         tx = t2x[ij - 1];
  22757. /*<       TY= T2Y( IJ) >*/
  22758.         ty = t2y[ij - 1];
  22759. /*<       TZ= T2Z( IJ) >*/
  22760.         tz = t2z[ij - 1];
  22761. /*<       ETK= EXK* TX+ EYK* TY+ EZK* TZ >*/
  22762.         z__3.r = tx * dataj_1.exk.r, z__3.i = tx * dataj_1.exk.i;
  22763.         z__4.r = ty * dataj_1.eyk.r, z__4.i = ty * dataj_1.eyk.i;
  22764.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22765.         z__5.r = tz * dataj_1.ezk.r, z__5.i = tz * dataj_1.ezk.i;
  22766.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22767.         etk.r = z__1.r, etk.i = z__1.i;
  22768. /*<       ETS= EXS* TX+ EYS* TY+ EZS* TZ >*/
  22769.         z__3.r = tx * dataj_1.exs.r, z__3.i = tx * dataj_1.exs.i;
  22770.         z__4.r = ty * dataj_1.eys.r, z__4.i = ty * dataj_1.eys.i;
  22771.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22772.         z__5.r = tz * dataj_1.ezs.r, z__5.i = tz * dataj_1.ezs.i;
  22773.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22774.         ets.r = z__1.r, ets.i = z__1.i;
  22775. /*<       ETC= EXC* TX+ EYC* TY+ EZC* TZ >*/
  22776.         z__3.r = tx * dataj_1.exc.r, z__3.i = tx * dataj_1.exc.i;
  22777.         z__4.r = ty * dataj_1.eyc.r, z__4.i = ty * dataj_1.eyc.i;
  22778.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22779.         z__5.r = tz * dataj_1.ezc.r, z__5.i = tz * dataj_1.ezc.i;
  22780.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22781.         etc.r = z__1.r, etc.i = z__1.i;
  22782. /*<    >*/
  22783.         i__4 = i1;
  22784.         i__5 = i1;
  22785.         i__6 = jx - 1;
  22786.         z__6.r = segj_1.ax[i__6] * etk.r, z__6.i = segj_1.ax[i__6] * 
  22787.             etk.i;
  22788.         i__7 = jx - 1;
  22789.         z__7.r = segj_1.bx[i__7] * ets.r, z__7.i = segj_1.bx[i__7] * 
  22790.             ets.i;
  22791.         z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
  22792.         i__2 = jx - 1;
  22793.         z__8.r = segj_1.cx[i__2] * etc.r, z__8.i = segj_1.cx[i__2] * 
  22794.             etc.i;
  22795.         z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
  22796.         z__3.r = z__4.r * curd.r - z__4.i * curd.i, z__3.i = z__4.r * 
  22797.             curd.i + z__4.i * curd.r;
  22798.         i__8 = ij - 1;
  22799.         z__2.r = angl_1.salp[i__8] * z__3.r, z__2.i = angl_1.salp[i__8] * 
  22800.             z__3.i;
  22801.         z__1.r = e[i__5].r + z__2.r, z__1.i = e[i__5].i + z__2.i;
  22802.         e[i__4].r = z__1.r, e[i__4].i = z__1.i;
  22803. /*<       I1= I1+1 >*/
  22804.         ++i1;
  22805. /*<       TX= T1X( IJ) >*/
  22806.         tx = t1x[ij - 1];
  22807. /*<       TY= T1Y( IJ) >*/
  22808.         ty = t1y[ij - 1];
  22809. /*<       TZ= T1Z( IJ) >*/
  22810.         tz = t1z[ij - 1];
  22811. /*<       ETK= EXK* TX+ EYK* TY+ EZK* TZ >*/
  22812.         z__3.r = tx * dataj_1.exk.r, z__3.i = tx * dataj_1.exk.i;
  22813.         z__4.r = ty * dataj_1.eyk.r, z__4.i = ty * dataj_1.eyk.i;
  22814.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22815.         z__5.r = tz * dataj_1.ezk.r, z__5.i = tz * dataj_1.ezk.i;
  22816.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22817.         etk.r = z__1.r, etk.i = z__1.i;
  22818. /*<       ETS= EXS* TX+ EYS* TY+ EZS* TZ >*/
  22819.         z__3.r = tx * dataj_1.exs.r, z__3.i = tx * dataj_1.exs.i;
  22820.         z__4.r = ty * dataj_1.eys.r, z__4.i = ty * dataj_1.eys.i;
  22821.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22822.         z__5.r = tz * dataj_1.ezs.r, z__5.i = tz * dataj_1.ezs.i;
  22823.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22824.         ets.r = z__1.r, ets.i = z__1.i;
  22825. /*<       ETC= EXC* TX+ EYC* TY+ EZC* TZ >*/
  22826.         z__3.r = tx * dataj_1.exc.r, z__3.i = tx * dataj_1.exc.i;
  22827.         z__4.r = ty * dataj_1.eyc.r, z__4.i = ty * dataj_1.eyc.i;
  22828.         z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  22829.         z__5.r = tz * dataj_1.ezc.r, z__5.i = tz * dataj_1.ezc.i;
  22830.         z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
  22831.         etc.r = z__1.r, etc.i = z__1.i;
  22832. /*<    >*/
  22833. /* L18: */
  22834.         i__4 = i1;
  22835.         i__5 = i1;
  22836.         i__6 = jx - 1;
  22837.         z__6.r = segj_1.ax[i__6] * etk.r, z__6.i = segj_1.ax[i__6] * 
  22838.             etk.i;
  22839.         i__7 = jx - 1;
  22840.         z__7.r = segj_1.bx[i__7] * ets.r, z__7.i = segj_1.bx[i__7] * 
  22841.             ets.i;
  22842.         z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
  22843.         i__2 = jx - 1;
  22844.         z__8.r = segj_1.cx[i__2] * etc.r, z__8.i = segj_1.cx[i__2] * 
  22845.             etc.i;
  22846.         z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
  22847.         z__3.r = z__4.r * curd.r - z__4.i * curd.i, z__3.i = z__4.r * 
  22848.             curd.i + z__4.i * curd.r;
  22849.         i__8 = ij - 1;
  22850.         z__2.r = angl_1.salp[i__8] * z__3.r, z__2.i = angl_1.salp[i__8] * 
  22851.             z__3.i;
  22852.         z__1.r = e[i__5].r + z__2.r, z__1.i = e[i__5].i + z__2.i;
  22853.         e[i__4].r = z__1.r, e[i__4].i = z__1.i;
  22854.     }
  22855. /*<    >*/
  22856. L19:
  22857.     if (zload_1.nload > 0 || zload_1.nlodf > 0) {
  22858.         i__4 = j;
  22859.         i__5 = j;
  22860.         i__6 = j - 1;
  22861.         z__3.r = zload_1.zarray[i__6].r * curd.r - zload_1.zarray[i__6].i 
  22862.             * curd.i, z__3.i = zload_1.zarray[i__6].r * curd.i + 
  22863.             zload_1.zarray[i__6].i * curd.r;
  22864.         d__1 = segj_1.ax[jx - 1] + segj_1.cx[jx - 1];
  22865.         z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
  22866.         z__1.r = e[i__5].r + z__2.r, z__1.i = e[i__5].i + z__2.i;
  22867.         e[i__4].r = z__1.r, e[i__4].i = z__1.i;
  22868.     }
  22869. /*<    20 CONTINUE >*/
  22870. /* L20: */
  22871.     }
  22872. /*<       RETURN >*/
  22873.     return 0;
  22874. /*<       END >*/
  22875. } /* qdsrc_ */
  22876.  
  22877. #undef sab
  22878. #undef ccj
  22879. #undef cab
  22880. #undef t2z
  22881. #undef t2y
  22882. #undef t2x
  22883. #undef t1z
  22884. #undef t1y
  22885. #undef t1x
  22886. #undef ccjx
  22887.  
  22888.  
  22889. /* *** */
  22890. /*     DOUBLE PRECISION 6/4/85 */
  22891.  
  22892. /*<       SUBROUTINE RDPAT >*/
  22893. /* Subroutine */ int rdpat_()
  22894. {
  22895.     /* Initialized data */
  22896.  
  22897.     static char hblk[6+1] = "      ";
  22898.     static char hpol[6*3+1] = "LINEARRIGHT LEFT  ";
  22899.     static char hcir[6+1] = "CIRCLE";
  22900.     static struct {
  22901.     char e_1[32];
  22902.     doublereal e_2;
  22903.     } equiv_1852 = { {' ', ' ', ' ', ' ', '-', ' ', ' ', ' ', 'P', 'O', 
  22904.         'W', 'E', 'R', ' ', ' ', ' ', '-', ' ', 'D', 'I', 'R', 'E', 
  22905.         ' ', ' ', 'C', 'T', 'I', 'V', 'E', ' ', ' ', ' '}, 0. };
  22906.  
  22907. #define igtp ((doublereal *)&equiv_1852)
  22908.  
  22909.     static struct {
  22910.     char e_1[32];
  22911.     doublereal e_2;
  22912.     } equiv_1853 = { {' ', 'M', 'A', 'J', 'O', 'R', ' ', ' ', ' ', 'M', 
  22913.         'I', 'N', 'O', 'R', ' ', ' ', ' ', 'V', 'E', 'R', 'T', '.', 
  22914.         ' ', ' ', ' ', 'H', 'O', 'R', '.', ' ', ' ', ' '}, 0. };
  22915.  
  22916. #define igax ((doublereal *)&equiv_1853)
  22917.  
  22918.     static struct {
  22919.     char e_1[80];
  22920.     doublereal e_2;
  22921.     } equiv_1854 = { {' ', 'M', 'A', 'J', 'O', 'R', ' ', ' ', ' ', 'A', 
  22922.         'X', 'I', 'S', ' ', ' ', ' ', ' ', 'M', 'I', 'N', 'O', 'R', 
  22923.         ' ', ' ', ' ', 'A', 'X', 'I', 'S', ' ', ' ', ' ', ' ', ' ', 
  22924.         ' ', 'V', 'E', 'R', ' ', ' ', 'T', 'I', 'C', 'A', 'L', ' ', 
  22925.         ' ', ' ', ' ', 'H', 'O', 'R', 'I', 'Z', ' ', ' ', 'O', 'N', 
  22926.         'T', 'A', 'L', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', 
  22927.         ' ', ' ', 'T', 'O', 'T', 'A', 'L', ' ', ' ', ' '}, 0. };
  22928.  
  22929. #define igntp ((doublereal *)&equiv_1854)
  22930.  
  22931.     static doublereal pi = 3.141592654;
  22932.     static doublereal ta = .01745329252;
  22933.     static doublereal td = 57.29577951;
  22934.     static integer normax = 800;
  22935.  
  22936.     /* Format strings */
  22937.     static char fmt_35[] = "(///,31x,\002- - - FAR FIELD GROUND PARAMETERS -\
  22938.  - -\002,//)";
  22939.     static char fmt_36[] = "(40x,\002RADIAL WIRE GROUND SCREEN\002,/,40x,i5\
  22940. ,\002 WIRES\002,/,40x,\002WIRE LENGTH=\002,f8.2,\002 METERS\002,/,40x,\002WI\
  22941. RE RADIUS=\002,1p,e10.3,\002 METERS\002)";
  22942.     static char fmt_37[] = "(40x,a6,\002 CLIFF\002,/,40x,\002EDGE DISTANCE\
  22943. =\002,f9.2,\002 METERS\002,/,40x,\002HEIGHT=\002,f8.2,\002 METERS\002,/,40x\
  22944. ,\002SECOND MEDIUM -\002,/,40x,\002RELA\002,\002TIVE DIELECTRIC CONST.=\002,\
  22945. f7.3,/,40x,\002CONDUCTIVITY=\002,1p,e10.3,\002 MHOS\002)";
  22946.     static char fmt_41[] = "(///,28x,\002 - - - RADIATED FIELDS NEAR GROUND \
  22947. - - -\002,//,8x,\002- - - LOCATION - - -\002,10x,\002- - E(THETA) - -\002,8x,\
  22948. \002- - E(PHI) -\002\002 -\002,8x,\002- - E(RADIAL) - -\002,/,7x,\002RHO\002\
  22949. ,6x,\002PHI\002,9x,\002Z\002,12x,\002MAG\002,6x,\002PHASE\002,9x,\002MAG\002\
  22950. ,6x,\002PHASE\002,9x,\002MAG\002,6x,\002PHASE\002,/,5x,\002METERS\002,3x,\
  22951. \002DEGREES\002,4x,\002METERS\002,8x,\002VOLTS/M\002,3x,\002DEGREES\002,6x\
  22952. ,\002VOLTS/M\002,3x,\002DEGREES\002,6x,\002VOLTS/M\002,3x,\002DEGREES\002,/)";
  22953.  
  22954.     static char fmt_38[] = "(///,48x,\002- - - RADIATION PATTERNS - - -\002)";
  22955.  
  22956.     static char fmt_39[] = "(54x,\002RANGE=\002,1p,e13.6,\002 METERS\002,/,5\
  22957. 4x,\002EXP(-JKR)/R=\002,e12.5,\002 AT PHASE\002,0p,f7.2,\002 DEGREES\002,/)";
  22958.     static char fmt_40[] = "(/,2x,\002- - ANGLES - -\002,7x,2a6,\002GAINS \
  22959. -\002,7x,\002- - - POLARI\002,\002ZATION - - -\002,4x,\002- - - E(THETA) - -\
  22960.  -\002,4x,\002- - - E(PHI) - -\002,\002 -\002,/,2x,\002THETA\002,5x,\002PH\
  22961. I\002,7x,a6,2x,a6,3x,\002TOTAL\002,6x,\002AXIAL\002,5x,\002TILT\002,3x,\002S\
  22962. ENSE\002,2(5x,\002MAGNITUDE\002,4x,\002PHASE\002),/,2(1x,\002DEGREES\002,1x)\
  22963. ,3(6x,\002DB\002),8x,\002RATIO\002,5x,\002DEG.\002,8x,2(6x,\002VOLTS/M\002,4\
  22964. x,\002DEGRE\002,\002ES\002))";
  22965.     static char fmt_42[] = "(1x,f7.2,f9.2,3x,3f8.2,f11.5,f9.2,2x,a6,2(1p,e15\
  22966. .5,0p,f9.2))";
  22967.     static char fmt_43[] = "(3x,f9.2,2x,f7.2,2x,f9.2,1x,3(3x,1p,e11.4,2x,0p,\
  22968. f7.2))";
  22969.     static char fmt_44[] = "(//,3x,\002AVERAGE POWER GAIN=\002,1p,e12.5,7x\
  22970. ,\002SOLID ANGLE U\002,\002SED IN AVERAGING=(\002,0p,f7.4,\002)*PI STERADIAN\
  22971. S.\002,//)";
  22972.     static char fmt_45[] = "(//,37x,\002- - - - NORMALIZED GAIN - - - -\002,\
  22973. //,37x,2a6,\002GAI\002,\002N\002,/,38x,\002NORMALIZATION FACTOR =\002,f9.2\
  22974. ,\002 DB\002,//,3(4x,\002- - ANGLES' - -\002,6x,\002GAIN\002,7x),/,3(4x,\002\
  22975. THETA\002,5x,\002PHI\002,8x,\002DB\002,8x),/,3(3x,\002DEGREES\002,2x,\002DEG\
  22976. REES\002,16x))";
  22977.     static char fmt_46[] = "(3(1x,2f9.2,1x,f9.2,6x))";
  22978.  
  22979.     /* System generated locals */
  22980.     integer i__1, i__2;
  22981.     doublereal d__1, d__2, d__3;
  22982.     doublecomplex z__1, z__2, z__3;
  22983.  
  22984.     /* Builtin functions */
  22985.     integer s_wsfe(), e_wsfe(), do_fio();
  22986.     /* Subroutine */ int s_copy();
  22987.     void z_div(), z_sqrt();
  22988.     double d_int(), z_abs();
  22989.     void d_cnjg();
  22990.     double sqrt(), cos(), sin();
  22991.     integer s_wsle(), do_lio(), e_wsle();
  22992.  
  22993.     /* Local variables */
  22994.     extern doublereal cang_();
  22995.     extern /* Subroutine */ int ffld_(), gfld_();
  22996.     static doublereal erda, epha, prad, gcon, gcop, gmax, exra, pint, exrm, 
  22997.         thet, erdm, ethm, etha, ephm, dfaz, gnmj, gnmn, gtot, dfaz2, 
  22998.         ephm2;
  22999.     extern doublereal atgn2_();
  23000.     static doublereal ethm2;
  23001.     static integer itmp1, itmp2, itmp3, itmp4, i, j;
  23002.     static char hclif[6];
  23003.     static doublereal cdfaz, tilta, axrat;
  23004.     static char isens[6];
  23005.     static doublereal emajr2, eminr2, da, tstor1, tstor2, stilta;
  23006.     extern doublereal db10_();
  23007.     static doublereal pha;
  23008.     static doublecomplex erd, eph, eth;
  23009.     static doublereal phi;
  23010.     static integer kph, kth;
  23011.     static doublereal tha, gnv, gnh, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6;
  23012.  
  23013.     /* Fortran I/O blocks */
  23014.     static cilist io___1774 = { 0, 6, 0, fmt_35, 0 };
  23015.     static cilist io___1775 = { 0, 6, 0, fmt_36, 0 };
  23016.     static cilist io___1777 = { 0, 6, 0, fmt_37, 0 };
  23017.     static cilist io___1778 = { 0, 6, 0, fmt_41, 0 };
  23018.     static cilist io___1783 = { 0, 6, 0, fmt_38, 0 };
  23019.     static cilist io___1786 = { 0, 6, 0, fmt_39, 0 };
  23020.     static cilist io___1787 = { 0, 6, 0, fmt_40, 0 };
  23021.     static cilist io___1833 = { 0, 6, 0, fmt_42, 0 };
  23022.     static cilist io___1834 = { 0, 8, 0, 0, 0 };
  23023.     static cilist io___1835 = { 0, 8, 0, 0, 0 };
  23024.     static cilist io___1836 = { 0, 8, 0, 0, 0 };
  23025.     static cilist io___1837 = { 0, 8, 0, 0, 0 };
  23026.     static cilist io___1838 = { 0, 8, 0, 0, 0 };
  23027.     static cilist io___1839 = { 0, 8, 0, 0, 0 };
  23028.     static cilist io___1840 = { 0, 8, 0, 0, 0 };
  23029.     static cilist io___1841 = { 0, 8, 0, 0, 0 };
  23030.     static cilist io___1842 = { 0, 8, 0, 0, 0 };
  23031.     static cilist io___1843 = { 0, 8, 0, 0, 0 };
  23032.     static cilist io___1844 = { 0, 6, 0, fmt_43, 0 };
  23033.     static cilist io___1845 = { 0, 6, 0, fmt_44, 0 };
  23034.     static cilist io___1846 = { 0, 6, 0, fmt_45, 0 };
  23035.     static cilist io___1849 = { 0, 6, 0, fmt_46, 0 };
  23036.     static cilist io___1850 = { 0, 6, 0, fmt_46, 0 };
  23037.     static cilist io___1851 = { 0, 6, 0, fmt_46, 0 };
  23038.  
  23039.  
  23040. /* *** */
  23041. /*     COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN */
  23042. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  23043. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  23044. /*     INTEGER HPOL,HBLK,HCIR,HCLIF */
  23045. /*<       REAL  IGNTP, IGAX, IGTP, COM >*/
  23046. /*<       COMPLEX  ETH, EPH, ERD, ZRATI, ZRATI2, T1, FRATI >*/
  23047. /*<    >*/
  23048. /*<       COMMON  /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
  23049. /*<    >*/
  23050. /*<    >*/
  23051. /* *** */
  23052. /*<       COMMON  /SCRATM/ GAIN(N2M) >*/
  23053. /* *** */
  23054. /*<       COMMON  /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
  23055. /*<       DIMENSION  IGTP(4), IGAX(4), IGNTP(10) >*/
  23056. /*<       CHARACTER*6 HPOL(3),HCLIF,ISENS,HCIR,HBLK >*/
  23057. /*<       DATA   HBLK/6H      / >*/
  23058. /*<       DATA   HPOL/6HLINEAR,5HRIGHT,4HLEFT/, HCIR/6HCIRCLE/ >*/
  23059. /*<       DATA   IGTP/6H    - ,6HPOWER ,6H- DIRE,6HCTIVE / >*/
  23060. /*<       DATA   IGAX/6H MAJOR,6H MINOR,6H VERT.,6H HOR. / >*/
  23061. /*<    >*/
  23062. /*<       DATA   PI, TA, TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/ >*/
  23063. /*<       DATA   NORMAX/800/ >*/
  23064. /*<       IF( IFAR.LT.2) GOTO 2 >*/
  23065.     if (gnd_1.ifar < 2) {
  23066.     goto L2;
  23067.     }
  23068. /*<       WRITE( 6,35)  >*/
  23069.     s_wsfe(&io___1774);
  23070.     e_wsfe();
  23071. /*<       IF( IFAR.LE.3) GOTO 1 >*/
  23072.     if (gnd_1.ifar <= 3) {
  23073.     goto L1;
  23074.     }
  23075. /*<       WRITE( 6,36)  NRADL, SCRWLT, SCRWRT >*/
  23076.     s_wsfe(&io___1775);
  23077.     do_fio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
  23078.     do_fio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
  23079.     do_fio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
  23080.     e_wsfe();
  23081. /*<       IF( IFAR.EQ.4) GOTO 2 >*/
  23082.     if (gnd_1.ifar == 4) {
  23083.     goto L2;
  23084.     }
  23085. /*<     1 IF( IFAR.EQ.2.OR. IFAR.EQ.5) HCLIF= HPOL(1) >*/
  23086. L1:
  23087.     if (gnd_1.ifar == 2 || gnd_1.ifar == 5) {
  23088.     s_copy(hclif, hpol, 6L, 6L);
  23089.     }
  23090. /*<       IF( IFAR.EQ.3.OR. IFAR.EQ.6) HCLIF= HCIR >*/
  23091.     if (gnd_1.ifar == 3 || gnd_1.ifar == 6) {
  23092.     s_copy(hclif, hcir, 6L, 6L);
  23093.     }
  23094. /*<       CL= CLT/ WLAM >*/
  23095.     gnd_1.cl = fpat_1.clt / data_1.wlam;
  23096. /*<       CH= CHT/ WLAM >*/
  23097.     gnd_1.ch = fpat_1.cht / data_1.wlam;
  23098. /*<       ZRATI2= SQRT(1./ CMPLX( EPSR2,- SIG2* WLAM*59.96)) >*/
  23099.     d__2 = -fpat_1.sig2 * data_1.wlam;
  23100.     d__1 = d__2 * 59.96;
  23101.     z__3.r = fpat_1.epsr2, z__3.i = d__1;
  23102.     z_div(&z__2, &c_b48, &z__3);
  23103.     z_sqrt(&z__1, &z__2);
  23104.     gnd_1.zrati2.r = z__1.r, gnd_1.zrati2.i = z__1.i;
  23105. /*<       WRITE( 6,37)  HCLIF, CLT, CHT, EPSR2, SIG2 >*/
  23106.     s_wsfe(&io___1777);
  23107.     do_fio(&c__1, hclif, 6L);
  23108.     do_fio(&c__1, (char *)&fpat_1.clt, (ftnlen)sizeof(doublereal));
  23109.     do_fio(&c__1, (char *)&fpat_1.cht, (ftnlen)sizeof(doublereal));
  23110.     do_fio(&c__1, (char *)&fpat_1.epsr2, (ftnlen)sizeof(doublereal));
  23111.     do_fio(&c__1, (char *)&fpat_1.sig2, (ftnlen)sizeof(doublereal));
  23112.     e_wsfe();
  23113. /*<     2 IF( IFAR.NE.1) GOTO 3 >*/
  23114. L2:
  23115.     if (gnd_1.ifar != 1) {
  23116.     goto L3;
  23117.     }
  23118. /*<       WRITE( 6,41)  >*/
  23119.     s_wsfe(&io___1778);
  23120.     e_wsfe();
  23121. /*<       GOTO 5 >*/
  23122.     goto L5;
  23123. /*<     3 I=2* IPD+1 >*/
  23124. L3:
  23125.     i = (fpat_1.ipd << 1) + 1;
  23126. /*<       J= I+1 >*/
  23127.     j = i + 1;
  23128. /*<       ITMP1=2* IAX+1 >*/
  23129.     itmp1 = (fpat_1.iax << 1) + 1;
  23130. /*<       ITMP2= ITMP1+1 >*/
  23131.     itmp2 = itmp1 + 1;
  23132. /*<       WRITE( 6,38)  >*/
  23133.     s_wsfe(&io___1783);
  23134.     e_wsfe();
  23135. /*<       IF( RFLD.LT.1.D-20) GOTO 4 >*/
  23136.     if (fpat_1.rfld < 1e-20) {
  23137.     goto L4;
  23138.     }
  23139. /*<       EXRM=1./ RFLD >*/
  23140.     exrm = 1. / fpat_1.rfld;
  23141. /*<       EXRA= RFLD/ WLAM >*/
  23142.     exra = fpat_1.rfld / data_1.wlam;
  23143. /*<       EXRA=-360.*( EXRA- AINT( EXRA)) >*/
  23144.     exra = (exra - d_int(&exra)) * -360.;
  23145. /*<       WRITE( 6,39)  RFLD, EXRM, EXRA >*/
  23146.     s_wsfe(&io___1786);
  23147.     do_fio(&c__1, (char *)&fpat_1.rfld, (ftnlen)sizeof(doublereal));
  23148.     do_fio(&c__1, (char *)&exrm, (ftnlen)sizeof(doublereal));
  23149.     do_fio(&c__1, (char *)&exra, (ftnlen)sizeof(doublereal));
  23150.     e_wsfe();
  23151. /*<     4 WRITE( 6,40)  IGTP( I), IGTP( J), IGAX( ITMP1), IGAX( ITMP2) >*/
  23152. L4:
  23153.     s_wsfe(&io___1787);
  23154.     do_fio(&c__1, (char *)&igtp[i - 1], (ftnlen)sizeof(doublereal));
  23155.     do_fio(&c__1, (char *)&igtp[j - 1], (ftnlen)sizeof(doublereal));
  23156.     do_fio(&c__1, (char *)&igax[itmp1 - 1], (ftnlen)sizeof(doublereal));
  23157.     do_fio(&c__1, (char *)&igax[itmp2 - 1], (ftnlen)sizeof(doublereal));
  23158.     e_wsfe();
  23159. /*<     5 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 7 >*/
  23160. L5:
  23161.     if (fpat_1.ixtyp == 0 || fpat_1.ixtyp == 5) {
  23162.     goto L7;
  23163.     }
  23164. /*<       IF( IXTYP.EQ.4) GOTO 6 >*/
  23165.     if (fpat_1.ixtyp == 4) {
  23166.     goto L6;
  23167.     }
  23168. /*<       PRAD=0. >*/
  23169.     prad = 0.;
  23170. /*<       GCON=4.* PI/(1.+ XPR6* XPR6) >*/
  23171.     gcon = pi * 4. / (fpat_1.xpr6 * fpat_1.xpr6 + 1.);
  23172. /*<       GCOP= GCON >*/
  23173.     gcop = gcon;
  23174. /*<       GOTO 8 >*/
  23175.     goto L8;
  23176. /*<     6 PINR=394.51* XPR6* XPR6* WLAM* WLAM >*/
  23177. L6:
  23178.     d__3 = fpat_1.xpr6 * 394.51;
  23179.     d__2 = d__3 * fpat_1.xpr6;
  23180.     d__1 = d__2 * data_1.wlam;
  23181.     fpat_1.pinr = d__1 * data_1.wlam;
  23182. /*<     7 GCOP= WLAM* WLAM*2.* PI/(376.73* PINR) >*/
  23183. L7:
  23184.     d__2 = data_1.wlam * data_1.wlam;
  23185.     d__1 = d__2 * 2.;
  23186.     gcop = d__1 * pi / (fpat_1.pinr * 376.73);
  23187. /*<       PRAD= PINR- PLOSS- PNLR >*/
  23188.     prad = fpat_1.pinr - fpat_1.ploss - fpat_1.pnlr;
  23189. /*<       GCON= GCOP >*/
  23190.     gcon = gcop;
  23191. /*<       IF( IPD.NE.0) GCON= GCON* PINR/ PRAD >*/
  23192.     if (fpat_1.ipd != 0) {
  23193.     gcon = gcon * fpat_1.pinr / prad;
  23194.     }
  23195. /*<     8 I=0 >*/
  23196. L8:
  23197.     i = 0;
  23198. /*<       GMAX=-1.E10 >*/
  23199.     gmax = -1e10;
  23200. /*<       PINT=0. >*/
  23201.     pint = 0.;
  23202. /*<       TMP1= DPH* TA >*/
  23203.     tmp1 = fpat_1.dph * ta;
  23204. /*<       TMP2=.5* DTH* TA >*/
  23205.     d__1 = fpat_1.dth * .5;
  23206.     tmp2 = d__1 * ta;
  23207. /*<       PHI= PHIS- DPH >*/
  23208.     phi = fpat_1.phis - fpat_1.dph;
  23209. /*<       DO 29  KPH=1, NPH >*/
  23210.     i__1 = fpat_1.nph;
  23211.     for (kph = 1; kph <= i__1; ++kph) {
  23212. /*<       PHI= PHI+ DPH >*/
  23213.     phi += fpat_1.dph;
  23214. /*<       PHA= PHI* TA >*/
  23215.     pha = phi * ta;
  23216. /*<       THET= THETS- DTH >*/
  23217.     thet = fpat_1.thets - fpat_1.dth;
  23218. /*<       DO 29  KTH=1, NTH >*/
  23219.     i__2 = fpat_1.nth;
  23220.     for (kth = 1; kth <= i__2; ++kth) {
  23221. /*<       THET= THET+ DTH >*/
  23222.         thet += fpat_1.dth;
  23223. /*<       IF( KSYMP.EQ.2.AND. THET.GT.90.01.AND. IFAR.NE.1) GOTO 29 >*/
  23224.         if (gnd_1.ksymp == 2 && thet > 90.01 && gnd_1.ifar != 1) {
  23225.         goto L29;
  23226.         }
  23227. /*<       THA= THET* TA >*/
  23228.         tha = thet * ta;
  23229. /*<       IF( IFAR.EQ.1) GOTO 9 >*/
  23230.         if (gnd_1.ifar == 1) {
  23231.         goto L9;
  23232.         }
  23233. /*<       CALL FFLD( THA, PHA, ETH, EPH) >*/
  23234.         ffld_(&tha, &pha, ð, &eph);
  23235. /*<       GOTO 10 >*/
  23236.         goto L10;
  23237. /*<    >*/
  23238. L9:
  23239.         d__1 = fpat_1.rfld / data_1.wlam;
  23240.         d__2 = thet / data_1.wlam;
  23241.         gfld_(&d__1, &pha, &d__2, ð, &eph, &erd, &gnd_1.zrati, &
  23242.             gnd_1.ksymp);
  23243. /*<       ERDM= ABS( ERD) >*/
  23244.         erdm = z_abs(&erd);
  23245. /*<       ERDA= CANG( ERD) >*/
  23246.         erda = cang_(&erd);
  23247. /*<    10 ETHM2= REAL( ETH* CONJG( ETH)) >*/
  23248. L10:
  23249.         d_cnjg(&z__2, ð);
  23250.         z__1.r = eth.r * z__2.r - eth.i * z__2.i, z__1.i = eth.r * z__2.i 
  23251.             + eth.i * z__2.r;
  23252.         ethm2 = z__1.r;
  23253. /*<       ETHM= SQRT( ETHM2) >*/
  23254.         ethm = sqrt(ethm2);
  23255. /*<       ETHA= CANG( ETH) >*/
  23256.         etha = cang_(ð);
  23257. /*<       EPHM2= REAL( EPH* CONJG( EPH)) >*/
  23258.         d_cnjg(&z__2, &eph);
  23259.         z__1.r = eph.r * z__2.r - eph.i * z__2.i, z__1.i = eph.r * z__2.i 
  23260.             + eph.i * z__2.r;
  23261.         ephm2 = z__1.r;
  23262. /*<       EPHM= SQRT( EPHM2) >*/
  23263.         ephm = sqrt(ephm2);
  23264. /*<       EPHA= CANG( EPH) >*/
  23265.         epha = cang_(&eph);
  23266. /*     ELLIPTICAL POLARIZATION CALC. */
  23267. /*<       IF( IFAR.EQ.1) GOTO 28 >*/
  23268.         if (gnd_1.ifar == 1) {
  23269.         goto L28;
  23270.         }
  23271. /*<       IF( ETHM2.GT.1.D-20.OR. EPHM2.GT.1.D-20) GOTO 11 >*/
  23272.         if (ethm2 > 1e-20 || ephm2 > 1e-20) {
  23273.         goto L11;
  23274.         }
  23275. /*<       TILTA=0. >*/
  23276.         tilta = 0.;
  23277. /*<       EMAJR2=0. >*/
  23278.         emajr2 = 0.;
  23279. /*<       EMINR2=0. >*/
  23280.         eminr2 = 0.;
  23281. /*<       AXRAT=0. >*/
  23282.         axrat = 0.;
  23283. /*<       ISENS= HBLK >*/
  23284.         s_copy(isens, hblk, 6L, 6L);
  23285. /*<       GOTO 16 >*/
  23286.         goto L16;
  23287. /*<    11 DFAZ= EPHA- ETHA >*/
  23288. L11:
  23289.         dfaz = epha - etha;
  23290. /*<       IF( EPHA.LT.0.) GOTO 12 >*/
  23291.         if (epha < 0.) {
  23292.         goto L12;
  23293.         }
  23294. /*<       DFAZ2= DFAZ-360. >*/
  23295.         dfaz2 = dfaz - 360.;
  23296. /*<       GOTO 13 >*/
  23297.         goto L13;
  23298. /*<    12 DFAZ2= DFAZ+360. >*/
  23299. L12:
  23300.         dfaz2 = dfaz + 360.;
  23301. /*<    13 IF( ABS( DFAZ).GT. ABS( DFAZ2)) DFAZ= DFAZ2 >*/
  23302. L13:
  23303.         if (abs(dfaz) > abs(dfaz2)) {
  23304.         dfaz = dfaz2;
  23305.         }
  23306. /*<       CDFAZ= COS( DFAZ* TA) >*/
  23307.         cdfaz = cos(dfaz * ta);
  23308. /*<       TSTOR1= ETHM2- EPHM2 >*/
  23309.         tstor1 = ethm2 - ephm2;
  23310. /*<       TSTOR2=2.* EPHM* ETHM* CDFAZ >*/
  23311.         d__2 = ephm * 2.;
  23312.         d__1 = d__2 * ethm;
  23313.         tstor2 = d__1 * cdfaz;
  23314. /*<       TILTA=.5* ATGN2( TSTOR2, TSTOR1) >*/
  23315.         tilta = atgn2_(&tstor2, &tstor1) * .5;
  23316. /*<       STILTA= SIN( TILTA) >*/
  23317.         stilta = sin(tilta);
  23318. /*<       TSTOR1= TSTOR1* STILTA* STILTA >*/
  23319.         d__1 = tstor1 * stilta;
  23320.         tstor1 = d__1 * stilta;
  23321. /*<       TSTOR2= TSTOR2* STILTA* COS( TILTA) >*/
  23322.         d__1 = tstor2 * stilta;
  23323.         tstor2 = d__1 * cos(tilta);
  23324. /*<       EMAJR2=- TSTOR1+ TSTOR2+ ETHM2 >*/
  23325.         d__1 = -tstor1 + tstor2;
  23326.         emajr2 = d__1 + ethm2;
  23327. /*<       EMINR2= TSTOR1- TSTOR2+ EPHM2 >*/
  23328.         eminr2 = tstor1 - tstor2 + ephm2;
  23329. /*<       IF( EMINR2.LT.0.) EMINR2=0. >*/
  23330.         if (eminr2 < 0.) {
  23331.         eminr2 = 0.;
  23332.         }
  23333. /*<       AXRAT= SQRT( EMINR2/ EMAJR2) >*/
  23334.         axrat = sqrt(eminr2 / emajr2);
  23335. /*<       TILTA= TILTA* TD >*/
  23336.         tilta *= td;
  23337. /*<       IF( AXRAT.GT.1.D-5) GOTO 14 >*/
  23338.         if (axrat > 1e-5) {
  23339.         goto L14;
  23340.         }
  23341. /*<       ISENS= HPOL(1) >*/
  23342.         s_copy(isens, hpol, 6L, 6L);
  23343. /*<       GOTO 16 >*/
  23344.         goto L16;
  23345. /*<    14 IF( DFAZ.GT.0.) GOTO 15 >*/
  23346. L14:
  23347.         if (dfaz > 0.) {
  23348.         goto L15;
  23349.         }
  23350. /*<       ISENS= HPOL(2) >*/
  23351.         s_copy(isens, hpol + 6, 6L, 6L);
  23352. /*<       GOTO 16 >*/
  23353.         goto L16;
  23354. /*<    15 ISENS= HPOL(3) >*/
  23355. L15:
  23356.         s_copy(isens, hpol + 12, 6L, 6L);
  23357. /*<    16 GNMJ= DB10( GCON* EMAJR2) >*/
  23358. L16:
  23359.         d__1 = gcon * emajr2;
  23360.         gnmj = db10_(&d__1);
  23361. /*<       GNMN= DB10( GCON* EMINR2) >*/
  23362.         d__1 = gcon * eminr2;
  23363.         gnmn = db10_(&d__1);
  23364. /*<       GNV= DB10( GCON* ETHM2) >*/
  23365.         d__1 = gcon * ethm2;
  23366.         gnv = db10_(&d__1);
  23367. /*<       GNH= DB10( GCON* EPHM2) >*/
  23368.         d__1 = gcon * ephm2;
  23369.         gnh = db10_(&d__1);
  23370. /*<       GTOT= DB10( GCON*( ETHM2+ EPHM2)) >*/
  23371.         d__1 = gcon * (ethm2 + ephm2);
  23372.         gtot = db10_(&d__1);
  23373. /*<       IF( INOR.LT.1) GOTO 23 >*/
  23374.         if (fpat_1.inor < 1) {
  23375.         goto L23;
  23376.         }
  23377. /*<       I= I+1 >*/
  23378.         ++i;
  23379. /*<       IF( I.GT. NORMAX) GOTO 23 >*/
  23380.         if (i > normax) {
  23381.         goto L23;
  23382.         }
  23383. /*<       GOTO (17,18,19,20,21), INOR >*/
  23384.         switch ((int)fpat_1.inor) {
  23385.         case 1:  goto L17;
  23386.         case 2:  goto L18;
  23387.         case 3:  goto L19;
  23388.         case 4:  goto L20;
  23389.         case 5:  goto L21;
  23390.         }
  23391. /*<    17 TSTOR1= GNMJ >*/
  23392. L17:
  23393.         tstor1 = gnmj;
  23394. /*<       GOTO 22 >*/
  23395.         goto L22;
  23396. /*<    18 TSTOR1= GNMN >*/
  23397. L18:
  23398.         tstor1 = gnmn;
  23399. /*<       GOTO 22 >*/
  23400.         goto L22;
  23401. /*<    19 TSTOR1= GNV >*/
  23402. L19:
  23403.         tstor1 = gnv;
  23404. /*<       GOTO 22 >*/
  23405.         goto L22;
  23406. /*<    20 TSTOR1= GNH >*/
  23407. L20:
  23408.         tstor1 = gnh;
  23409. /*<       GOTO 22 >*/
  23410.         goto L22;
  23411. /*<    21 TSTOR1= GTOT >*/
  23412. L21:
  23413.         tstor1 = gtot;
  23414. /*<    22 GAIN( I)= TSTOR1 >*/
  23415. L22:
  23416.         scratm_3.gain[i - 1] = tstor1;
  23417. /*<       IF( TSTOR1.GT. GMAX) GMAX= TSTOR1 >*/
  23418.         if (tstor1 > gmax) {
  23419.         gmax = tstor1;
  23420.         }
  23421. /*<    23 IF( IAVP.EQ.0) GOTO 24 >*/
  23422. L23:
  23423.         if (fpat_1.iavp == 0) {
  23424.         goto L24;
  23425.         }
  23426. /*<       TSTOR1= GCOP*( ETHM2+ EPHM2) >*/
  23427.         tstor1 = gcop * (ethm2 + ephm2);
  23428. /*<       TMP3= THA- TMP2 >*/
  23429.         tmp3 = tha - tmp2;
  23430. /*<       TMP4= THA+ TMP2 >*/
  23431.         tmp4 = tha + tmp2;
  23432. /*<       IF( KTH.EQ.1) TMP3= THA >*/
  23433.         if (kth == 1) {
  23434.         tmp3 = tha;
  23435.         }
  23436. /*<       IF( KTH.EQ. NTH) TMP4= THA >*/
  23437.         if (kth == fpat_1.nth) {
  23438.         tmp4 = tha;
  23439.         }
  23440. /*<       DA= ABS( TMP1*( COS( TMP3)- COS( TMP4))) >*/
  23441.         da = (d__1 = tmp1 * (cos(tmp3) - cos(tmp4)), abs(d__1));
  23442. /*<       IF( KPH.EQ.1.OR. KPH.EQ. NPH) DA=.5* DA >*/
  23443.         if (kph == 1 || kph == fpat_1.nph) {
  23444.         da *= .5;
  23445.         }
  23446. /*<       PINT= PINT+ TSTOR1* DA >*/
  23447.         pint += tstor1 * da;
  23448. /*<       IF( IAVP.EQ.2) GOTO 29 >*/
  23449.         if (fpat_1.iavp == 2) {
  23450.         goto L29;
  23451.         }
  23452. /*<    24 IF( IAX.EQ.1) GOTO 25 >*/
  23453. L24:
  23454.         if (fpat_1.iax == 1) {
  23455.         goto L25;
  23456.         }
  23457. /*<       TMP5= GNMJ >*/
  23458.         tmp5 = gnmj;
  23459. /*<       TMP6= GNMN >*/
  23460.         tmp6 = gnmn;
  23461. /*<       GOTO 26 >*/
  23462.         goto L26;
  23463. /*<    25 TMP5= GNV >*/
  23464. L25:
  23465.         tmp5 = gnv;
  23466. /*<       TMP6= GNH >*/
  23467.         tmp6 = gnh;
  23468. /*<    26 ETHM= ETHM* WLAM >*/
  23469. L26:
  23470.         ethm *= data_1.wlam;
  23471. /*<       EPHM= EPHM* WLAM >*/
  23472.         ephm *= data_1.wlam;
  23473. /*<       IF( RFLD.LT.1.D-20) GOTO 27 >*/
  23474.         if (fpat_1.rfld < 1e-20) {
  23475.         goto L27;
  23476.         }
  23477. /*<       ETHM= ETHM* EXRM >*/
  23478.         ethm *= exrm;
  23479. /*<       ETHA= ETHA+ EXRA >*/
  23480.         etha += exra;
  23481. /*<       EPHM= EPHM* EXRM >*/
  23482.         ephm *= exrm;
  23483. /*<       EPHA= EPHA+ EXRA >*/
  23484.         epha += exra;
  23485. /*      GO TO 29 */
  23486. /* *** */
  23487. /* 28    WRITE(6,43)  RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA 
  23488. */
  23489. /*<    >*/
  23490. L27:
  23491.         s_wsfe(&io___1833);
  23492.         do_fio(&c__1, (char *)&thet, (ftnlen)sizeof(doublereal));
  23493.         do_fio(&c__1, (char *)&phi, (ftnlen)sizeof(doublereal));
  23494.         do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
  23495.         do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
  23496.         do_fio(&c__1, (char *)>ot, (ftnlen)sizeof(doublereal));
  23497.         do_fio(&c__1, (char *)&axrat, (ftnlen)sizeof(doublereal));
  23498.         do_fio(&c__1, (char *)&tilta, (ftnlen)sizeof(doublereal));
  23499.         do_fio(&c__1, isens, 6L);
  23500.         do_fio(&c__1, (char *)ðm, (ftnlen)sizeof(doublereal));
  23501.         do_fio(&c__1, (char *)ða, (ftnlen)sizeof(doublereal));
  23502.         do_fio(&c__1, (char *)&ephm, (ftnlen)sizeof(doublereal));
  23503.         do_fio(&c__1, (char *)&epha, (ftnlen)sizeof(doublereal));
  23504.         e_wsfe();
  23505. /*<       IF( IPLP1.NE.3) GOTO 299 >*/
  23506.         if (plot_1.iplp1 != 3) {
  23507.         goto L299;
  23508.         }
  23509. /*<       IF( IPLP3.EQ.0) GOTO 290 >*/
  23510.         if (plot_1.iplp3 == 0) {
  23511.         goto L290;
  23512.         }
  23513. /*<       IF( IPLP2.EQ.1.AND. IPLP3.EQ.1) WRITE( 8,*)  THET, ETHM, ETHA >*/
  23514.         if (plot_1.iplp2 == 1 && plot_1.iplp3 == 1) {
  23515.         s_wsle(&io___1834);
  23516.         do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
  23517.             );
  23518.         do_lio(&c__5, &c__1, (char *)ðm, (ftnlen)sizeof(doublereal)
  23519.             );
  23520.         do_lio(&c__5, &c__1, (char *)ða, (ftnlen)sizeof(doublereal)
  23521.             );
  23522.         e_wsle();
  23523.         }
  23524. /*<       IF( IPLP2.EQ.1.AND. IPLP3.EQ.2) WRITE( 8,*)  THET, EPHM, EPHA >*/
  23525.         if (plot_1.iplp2 == 1 && plot_1.iplp3 == 2) {
  23526.         s_wsle(&io___1835);
  23527.         do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
  23528.             );
  23529.         do_lio(&c__5, &c__1, (char *)&ephm, (ftnlen)sizeof(doublereal)
  23530.             );
  23531.         do_lio(&c__5, &c__1, (char *)&epha, (ftnlen)sizeof(doublereal)
  23532.             );
  23533.         e_wsle();
  23534.         }
  23535. /*<       IF( IPLP2.EQ.2.AND. IPLP3.EQ.1) WRITE( 8,*)  PHI, ETHM, ETHA >*/
  23536.         if (plot_1.iplp2 == 2 && plot_1.iplp3 == 1) {
  23537.         s_wsle(&io___1836);
  23538.         do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
  23539.             ;
  23540.         do_lio(&c__5, &c__1, (char *)ðm, (ftnlen)sizeof(doublereal)
  23541.             );
  23542.         do_lio(&c__5, &c__1, (char *)ða, (ftnlen)sizeof(doublereal)
  23543.             );
  23544.         e_wsle();
  23545.         }
  23546. /*<       IF( IPLP2.EQ.2.AND. IPLP3.EQ.2) WRITE( 8,*)  PHI, EPHM, EPHA >*/
  23547.         if (plot_1.iplp2 == 2 && plot_1.iplp3 == 2) {
  23548.         s_wsle(&io___1837);
  23549.         do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
  23550.             ;
  23551.         do_lio(&c__5, &c__1, (char *)&ephm, (ftnlen)sizeof(doublereal)
  23552.             );
  23553.         do_lio(&c__5, &c__1, (char *)&epha, (ftnlen)sizeof(doublereal)
  23554.             );
  23555.         e_wsle();
  23556.         }
  23557. /*<       IF( IPLP4.EQ.0) GOTO 299 >*/
  23558.         if (plot_1.iplp4 == 0) {
  23559.         goto L299;
  23560.         }
  23561. /*<   290 IF( IPLP2.EQ.1.AND. IPLP4.EQ.1) WRITE( 8,*)  THET, TMP5 >*/
  23562. L290:
  23563.         if (plot_1.iplp2 == 1 && plot_1.iplp4 == 1) {
  23564.         s_wsle(&io___1838);
  23565.         do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
  23566.             );
  23567.         do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal)
  23568.             );
  23569.         e_wsle();
  23570.         }
  23571. /*<       IF( IPLP2.EQ.1.AND. IPLP4.EQ.2) WRITE( 8,*)  THET, TMP6 >*/
  23572.         if (plot_1.iplp2 == 1 && plot_1.iplp4 == 2) {
  23573.         s_wsle(&io___1839);
  23574.         do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
  23575.             );
  23576.         do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal)
  23577.             );
  23578.         e_wsle();
  23579.         }
  23580. /*<       IF( IPLP2.EQ.1.AND. IPLP4.EQ.3) WRITE( 8,*)  THET, GTOT >*/
  23581.         if (plot_1.iplp2 == 1 && plot_1.iplp4 == 3) {
  23582.         s_wsle(&io___1840);
  23583.         do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
  23584.             );
  23585.         do_lio(&c__5, &c__1, (char *)>ot, (ftnlen)sizeof(doublereal)
  23586.             );
  23587.         e_wsle();
  23588.         }
  23589. /*<       IF( IPLP2.EQ.2.AND. IPLP4.EQ.1) WRITE( 8,*)  PHI, TMP5 >*/
  23590.         if (plot_1.iplp2 == 2 && plot_1.iplp4 == 1) {
  23591.         s_wsle(&io___1841);
  23592.         do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
  23593.             ;
  23594.         do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal)
  23595.             );
  23596.         e_wsle();
  23597.         }
  23598. /*<       IF( IPLP2.EQ.2.AND. IPLP4.EQ.2) WRITE( 8,*)  PHI, TMP6 >*/
  23599.         if (plot_1.iplp2 == 2 && plot_1.iplp4 == 2) {
  23600.         s_wsle(&io___1842);
  23601.         do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
  23602.             ;
  23603.         do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal)
  23604.             );
  23605.         e_wsle();
  23606.         }
  23607. /*<       IF( IPLP2.EQ.2.AND. IPLP4.EQ.3) WRITE( 8,*)  PHI, GTOT >*/
  23608.         if (plot_1.iplp2 == 2 && plot_1.iplp4 == 3) {
  23609.         s_wsle(&io___1843);
  23610.         do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
  23611.             ;
  23612.         do_lio(&c__5, &c__1, (char *)>ot, (ftnlen)sizeof(doublereal)
  23613.             );
  23614.         e_wsle();
  23615.         }
  23616. /*<       GOTO 299 >*/
  23617.         goto L299;
  23618. /*<    >*/
  23619. L28:
  23620.         s_wsfe(&io___1844);
  23621.         do_fio(&c__1, (char *)&fpat_1.rfld, (ftnlen)sizeof(doublereal));
  23622.         do_fio(&c__1, (char *)&phi, (ftnlen)sizeof(doublereal));
  23623.         do_fio(&c__1, (char *)&thet, (ftnlen)sizeof(doublereal));
  23624.         do_fio(&c__1, (char *)ðm, (ftnlen)sizeof(doublereal));
  23625.         do_fio(&c__1, (char *)ða, (ftnlen)sizeof(doublereal));
  23626.         do_fio(&c__1, (char *)&ephm, (ftnlen)sizeof(doublereal));
  23627.         do_fio(&c__1, (char *)&epha, (ftnlen)sizeof(doublereal));
  23628.         do_fio(&c__1, (char *)&erdm, (ftnlen)sizeof(doublereal));
  23629.         do_fio(&c__1, (char *)&erda, (ftnlen)sizeof(doublereal));
  23630.         e_wsfe();
  23631. /* *** */
  23632. /*<   299 CONTINUE >*/
  23633. L299:
  23634. /*<    29 CONTINUE >*/
  23635. L29:
  23636.         ;
  23637.     }
  23638.     }
  23639. /*<       IF( IAVP.EQ.0) GOTO 30 >*/
  23640.     if (fpat_1.iavp == 0) {
  23641.     goto L30;
  23642.     }
  23643. /*<       TMP3= THETS* TA >*/
  23644.     tmp3 = fpat_1.thets * ta;
  23645. /*<       TMP4= TMP3+ DTH* TA* DFLOAT( NTH-1) >*/
  23646.     d__1 = fpat_1.dth * ta;
  23647.     tmp4 = tmp3 + d__1 * (doublereal) (fpat_1.nth - 1);
  23648. /*<       TMP3= ABS( DPH* TA* DFLOAT( NPH-1)*( COS( TMP3)- COS( TMP4))) >*/
  23649.     d__3 = fpat_1.dph * ta;
  23650.     d__2 = d__3 * (doublereal) (fpat_1.nph - 1);
  23651.     tmp3 = (d__1 = d__2 * (cos(tmp3) - cos(tmp4)), abs(d__1));
  23652. /*<       PINT= PINT/ TMP3 >*/
  23653.     pint /= tmp3;
  23654. /*<       TMP3= TMP3/ PI >*/
  23655.     tmp3 /= pi;
  23656. /*<       WRITE( 6,44)  PINT, TMP3 >*/
  23657.     s_wsfe(&io___1845);
  23658.     do_fio(&c__1, (char *)&pint, (ftnlen)sizeof(doublereal));
  23659.     do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
  23660.     e_wsfe();
  23661. /*<    30 IF( INOR.EQ.0) GOTO 34 >*/
  23662. L30:
  23663.     if (fpat_1.inor == 0) {
  23664.     goto L34;
  23665.     }
  23666. /*<       IF( ABS( GNOR).GT.1.D-20) GMAX= GNOR >*/
  23667.     if (abs(fpat_1.gnor) > 1e-20) {
  23668.     gmax = fpat_1.gnor;
  23669.     }
  23670. /*<       ITMP1=( INOR-1)*2+1 >*/
  23671.     itmp1 = (fpat_1.inor - 1 << 1) + 1;
  23672. /*<       ITMP2= ITMP1+1 >*/
  23673.     itmp2 = itmp1 + 1;
  23674. /*<       WRITE( 6,45)  IGNTP( ITMP1), IGNTP( ITMP2), GMAX >*/
  23675.     s_wsfe(&io___1846);
  23676.     do_fio(&c__1, (char *)&igntp[itmp1 - 1], (ftnlen)sizeof(doublereal));
  23677.     do_fio(&c__1, (char *)&igntp[itmp2 - 1], (ftnlen)sizeof(doublereal));
  23678.     do_fio(&c__1, (char *)&gmax, (ftnlen)sizeof(doublereal));
  23679.     e_wsfe();
  23680. /*<       ITMP2= NPH* NTH >*/
  23681.     itmp2 = fpat_1.nph * fpat_1.nth;
  23682. /*<       IF( ITMP2.GT. NORMAX) ITMP2= NORMAX >*/
  23683.     if (itmp2 > normax) {
  23684.     itmp2 = normax;
  23685.     }
  23686. /*<       ITMP1=( ITMP2+2)/3 >*/
  23687.     itmp1 = (itmp2 + 2) / 3;
  23688. /*<       ITMP2= ITMP1*3- ITMP2 >*/
  23689.     itmp2 = itmp1 * 3 - itmp2;
  23690. /*<       ITMP3= ITMP1 >*/
  23691.     itmp3 = itmp1;
  23692. /*<       ITMP4=2* ITMP1 >*/
  23693.     itmp4 = itmp1 << 1;
  23694. /*<       IF( ITMP2.EQ.2) ITMP4= ITMP4-1 >*/
  23695.     if (itmp2 == 2) {
  23696.     --itmp4;
  23697.     }
  23698. /*<       DO 31  I=1, ITMP1 >*/
  23699.     i__2 = itmp1;
  23700.     for (i = 1; i <= i__2; ++i) {
  23701. /*<       ITMP3= ITMP3+1 >*/
  23702.     ++itmp3;
  23703. /*<       ITMP4= ITMP4+1 >*/
  23704.     ++itmp4;
  23705. /*<       J=( I-1)/ NTH >*/
  23706.     j = (i - 1) / fpat_1.nth;
  23707. /*<       TMP1= THETS+ DFLOAT( I- J* NTH-1)* DTH >*/
  23708.     tmp1 = fpat_1.thets + (doublereal) (i - j * fpat_1.nth - 1) * 
  23709.         fpat_1.dth;
  23710. /*<       TMP2= PHIS+ DFLOAT( J)* DPH >*/
  23711.     tmp2 = fpat_1.phis + (doublereal) j * fpat_1.dph;
  23712. /*<       J=( ITMP3-1)/ NTH >*/
  23713.     j = (itmp3 - 1) / fpat_1.nth;
  23714. /*<       TMP3= THETS+ DFLOAT( ITMP3- J* NTH-1)* DTH >*/
  23715.     tmp3 = fpat_1.thets + (doublereal) (itmp3 - j * fpat_1.nth - 1) * 
  23716.         fpat_1.dth;
  23717. /*<       TMP4= PHIS+ DFLOAT( J)* DPH >*/
  23718.     tmp4 = fpat_1.phis + (doublereal) j * fpat_1.dph;
  23719. /*<       J=( ITMP4-1)/ NTH >*/
  23720.     j = (itmp4 - 1) / fpat_1.nth;
  23721. /*<       TMP5= THETS+ DFLOAT( ITMP4- J* NTH-1)* DTH >*/
  23722.     tmp5 = fpat_1.thets + (doublereal) (itmp4 - j * fpat_1.nth - 1) * 
  23723.         fpat_1.dth;
  23724. /*<       TMP6= PHIS+ DFLOAT( J)* DPH >*/
  23725.     tmp6 = fpat_1.phis + (doublereal) j * fpat_1.dph;
  23726. /*<       TSTOR1= GAIN( I)- GMAX >*/
  23727.     tstor1 = scratm_3.gain[i - 1] - gmax;
  23728. /*<       IF( I.EQ. ITMP1.AND. ITMP2.NE.0) GOTO 32 >*/
  23729.     if (i == itmp1 && itmp2 != 0) {
  23730.         goto L32;
  23731.     }
  23732. /*<       TSTOR2= GAIN( ITMP3)- GMAX >*/
  23733.     tstor2 = scratm_3.gain[itmp3 - 1] - gmax;
  23734. /*<       PINT= GAIN( ITMP4)- GMAX >*/
  23735.     pint = scratm_3.gain[itmp4 - 1] - gmax;
  23736. /*<    >*/
  23737. /* L31: */
  23738.     s_wsfe(&io___1849);
  23739.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  23740.     do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  23741.     do_fio(&c__1, (char *)&tstor1, (ftnlen)sizeof(doublereal));
  23742.     do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
  23743.     do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
  23744.     do_fio(&c__1, (char *)&tstor2, (ftnlen)sizeof(doublereal));
  23745.     do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
  23746.     do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
  23747.     do_fio(&c__1, (char *)&pint, (ftnlen)sizeof(doublereal));
  23748.     e_wsfe();
  23749.     }
  23750. /*<       GOTO 34 >*/
  23751.     goto L34;
  23752. /*<    32 IF( ITMP2.EQ.2) GOTO 33 >*/
  23753. L32:
  23754.     if (itmp2 == 2) {
  23755.     goto L33;
  23756.     }
  23757. /*<       TSTOR2= GAIN( ITMP3)- GMAX >*/
  23758.     tstor2 = scratm_3.gain[itmp3 - 1] - gmax;
  23759. /*<       WRITE( 6,46)  TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2 >*/
  23760.     s_wsfe(&io___1850);
  23761.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  23762.     do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  23763.     do_fio(&c__1, (char *)&tstor1, (ftnlen)sizeof(doublereal));
  23764.     do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
  23765.     do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
  23766.     do_fio(&c__1, (char *)&tstor2, (ftnlen)sizeof(doublereal));
  23767.     e_wsfe();
  23768. /*<       GOTO 34 >*/
  23769.     goto L34;
  23770. /*<    33 WRITE( 6,46)  TMP1, TMP2, TSTOR1 >*/
  23771. L33:
  23772.     s_wsfe(&io___1851);
  23773.     do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
  23774.     do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
  23775.     do_fio(&c__1, (char *)&tstor1, (ftnlen)sizeof(doublereal));
  23776.     e_wsfe();
  23777.  
  23778. /*<    34 RETURN >*/
  23779. L34:
  23780.     return 0;
  23781. /*<    35 FORMAT(///,31X,'- - - FAR FIELD GROUND PARAMETERS - - -',//) >*/
  23782. /*<    >*/
  23783. /*<    >*/
  23784. /*<    38 FORMAT(///,48X,'- - - RADIATION PATTERNS - - -') >*/
  23785. /*<    >*/
  23786. /*<    >*/
  23787. /*<    >*/
  23788. /*<    >*/
  23789. /*<    43 FORMAT(3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2)) >*/
  23790. /*<    >*/
  23791. /*<    >*/
  23792. /*<    46 FORMAT(3(1X,2F9.2,1X,F9.2,6X)) >*/
  23793. /*<       END >*/
  23794. } /* rdpat_ */
  23795.  
  23796. #undef igntp
  23797. #undef igax
  23798. #undef igtp
  23799.  
  23800.  
  23801. /* *** */
  23802. /*     DOUBLE PRECISION 6/4/85 */
  23803.  
  23804. /*<       SUBROUTINE READGM( GM, I1, I2, X1, Y1, Z1, X2, Y2, Z2, RAD) >*/
  23805. /* Subroutine */ int readgm_(gm, i1, i2, x1, y1, z1, x2, y2, z2, rad, gm_len)
  23806. char *gm;
  23807. integer *i1, *i2;
  23808. doublereal *x1, *y1, *z1, *x2, *y2, *z2, *rad;
  23809. ftnlen gm_len;
  23810. {
  23811.     /* Format strings */
  23812.     static char fmt_10[] = "(a)";
  23813.  
  23814.     /* System generated locals */
  23815.     address a__1[3];
  23816.     integer i__1, i__2, i__3[3];
  23817.  
  23818.     /* Builtin functions */
  23819.     integer s_rsfe(), do_fio(), e_rsfe(), i_len();
  23820.     /* Subroutine */ int s_copy();
  23821.     integer i_indx();
  23822.     /* Subroutine */ int s_cat();
  23823.     integer s_wsle(), do_lio(), e_wsle();
  23824.     /* Subroutine */ int s_stop();
  23825.  
  23826.     /* Local variables */
  23827.     static integer indd, inde;
  23828.     static char line[133];
  23829.     extern /* Subroutine */ int atof_();
  23830.     static integer nlen, iarr[2];
  23831.     extern /* Subroutine */ int atoi_();
  23832.     static integer nlin;
  23833.     static doublereal rarr[7];
  23834.     static integer i;
  23835.     extern /* Subroutine */ int str0pc_();
  23836.     static integer ic, bp[9], ep[9];
  23837.     static char buffer[132];
  23838.     static integer ifound;
  23839.     static char buffer1[132];
  23840.     static integer ind;
  23841.  
  23842.     /* Fortran I/O blocks */
  23843.     static cilist io___1855 = { 0, 5, 0, fmt_10, 0 };
  23844.     static cilist io___1871 = { 0, 6, 0, 0, 0 };
  23845.     static cilist io___1872 = { 0, 6, 0, 0, 0 };
  23846.  
  23847.  
  23848. /* *** */
  23849. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  23850. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  23851. /*<       INTEGER*4 NTOT >*/
  23852. /*<       INTEGER*4 NINT >*/
  23853. /*<       INTEGER*4 NFLT >*/
  23854. /*<       PARAMETER (NTOT=9, NINT=2, NFLT=7) >*/
  23855. /*<       INTEGER  IARR( NINT), BP( NTOT), EP( NTOT) >*/
  23856. /*<       DIMENSION  RARR( NFLT) >*/
  23857. /*<       CHARACTER   LINE*133, GM*2, BUFFER*132, BUFFER1*132 >*/
  23858. /*<       READ( 5,10)  LINE >*/
  23859.     s_rsfe(&io___1855);
  23860.     do_fio(&c__1, line, 133L);
  23861.     e_rsfe();
  23862. /*<    10 FORMAT(A) >*/
  23863. /*<       NLIN= LEN(LINE) >*/
  23864.     nlin = i_len(line, 133L);
  23865. /*<       CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN)) >*/
  23866.     str0pc_(line, line, nlin, nlin);
  23867. /*<       IF( NLIN.LT.2) GOTO 110 >*/
  23868.     if (nlin < 2) {
  23869.     goto L110;
  23870.     }
  23871. /*<       IF( NLIN.LE.132) GOTO 20 >*/
  23872.     if (nlin <= 132) {
  23873.     goto L20;
  23874.     }
  23875. /*<       NLIN=132 >*/
  23876.     nlin = 132;
  23877. /*<       LINE(133:133)=' ' >*/
  23878.     line[132] = ' ';
  23879. /*<    20 GM= LINE(1:2) >*/
  23880. L20:
  23881.     s_copy(gm, line, 2L, 2L);
  23882. /*<       NLIN= NLIN+1 >*/
  23883.     ++nlin;
  23884. /*<       DO 30  I=1, NINT >*/
  23885.     for (i = 1; i <= 2; ++i) {
  23886. /*<    30 IARR( I)=0 >*/
  23887. /* L30: */
  23888.     iarr[i - 1] = 0;
  23889.     }
  23890. /*<       DO 40  I=1, NFLT >*/
  23891.     for (i = 1; i <= 7; ++i) {
  23892. /*<    40 RARR( I)=0.0 >*/
  23893. /* L40: */
  23894.     rarr[i - 1] = 0.;
  23895.     }
  23896. /*<       IC=2 >*/
  23897.     ic = 2;
  23898. /*<       IFOUND=0 >*/
  23899.     ifound = 0;
  23900. /*<       DO 70  I=1, NTOT >*/
  23901.     for (i = 1; i <= 9; ++i) {
  23902. /*<    50 IC= IC+1 >*/
  23903. L50:
  23904.     ++ic;
  23905. /*<       IF( IC.GE. NLIN) GOTO 80 >*/
  23906.     if (ic >= nlin) {
  23907.         goto L80;
  23908.     }
  23909. /*<       IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50 >*/
  23910.     if (line[ic - 1] == ' ' || line[ic - 1] == ',') {
  23911.         goto L50;
  23912.     }
  23913. /* BEGINNING OF I-TH NUMERICAL FIELD */
  23914. /*<       BP( I)= IC >*/
  23915.     bp[i - 1] = ic;
  23916. /*<    60 IC= IC+1 >*/
  23917. L60:
  23918.     ++ic;
  23919. /*<       IF( IC.GT. NLIN) GOTO 80 >*/
  23920.     if (ic > nlin) {
  23921.         goto L80;
  23922.     }
  23923. /*<       IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60 >*/
  23924.     if (line[ic - 1] != ' ' && line[ic - 1] != ',') {
  23925.         goto L60;
  23926.     }
  23927. /* END OF I-TH NUMERICAL FIELD */
  23928. /*<       EP( I)= IC-1 >*/
  23929.     ep[i - 1] = ic - 1;
  23930. /*<       IFOUND= I >*/
  23931.     ifound = i;
  23932. /*<    70 CONTINUE >*/
  23933. /* L70: */
  23934.     }
  23935. /*<    80 CONTINUE >*/
  23936. L80:
  23937. /*<       DO 90  I=1, MIN( IFOUND, NINT) >*/
  23938.     i__1 = min(ifound,2);
  23939.     for (i = 1; i <= i__1; ++i) {
  23940. /*<       NLEN= EP( I)- BP( I)+1 >*/
  23941.     nlen = ep[i - 1] - bp[i - 1] + 1;
  23942. /*<       BUFFER= LINE( BP( I): EP( I)) >*/
  23943.     i__2 = bp[i - 1] - 1;
  23944.     s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
  23945. /*<       IND= INDEX( BUFFER(1: NLEN),'.') >*/
  23946.     ind = i_indx(buffer, ".", nlen, 1L);
  23947. /*<       IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110 >*/
  23948.     if (ind > 0 && ind < nlen) {
  23949.         goto L110;
  23950.     }
  23951. /* USER PUT DECIMAL POINT FOR INTEGER */
  23952. /*<       IF( IND.EQ. NLEN) NLEN= NLEN-1 >*/
  23953.     if (ind == nlen) {
  23954.         --nlen;
  23955.     }
  23956. /*     READ( BUFFER(1: NLEN),111,ERR=110)  IARR( I) */
  23957. /* 11   format(i3) */
  23958. /*<       CALL ATOI(BUFFER,IARR(I)) >*/
  23959.     atoi_(buffer, &iarr[i - 1], 132L);
  23960. /*<    90 CONTINUE >*/
  23961. /* L90: */
  23962.     }
  23963. /*<       DO 100  I= NINT+1, IFOUND >*/
  23964.     i__1 = ifound;
  23965.     for (i = 3; i <= i__1; ++i) {
  23966. /*<       NLEN= EP( I)- BP( I)+1 >*/
  23967.     nlen = ep[i - 1] - bp[i - 1] + 1;
  23968. /*<       BUFFER= LINE( BP( I): EP( I)) >*/
  23969.     i__2 = bp[i - 1] - 1;
  23970.     s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
  23971. /*<       IND= INDEX( BUFFER(1: NLEN),'.') >*/
  23972.     ind = i_indx(buffer, ".", nlen, 1L);
  23973. /* USER FORGOT DECIMAL POINT FOR REAL */
  23974. /*<       IF( IND.EQ.0) THEN >*/
  23975.     if (ind == 0) {
  23976. /*<       IF( NLEN.GE.15) GOTO 110 >*/
  23977.         if (nlen >= 15) {
  23978.         goto L110;
  23979.         }
  23980. /*<       INDE= INDEX( BUFFER(1: NLEN),'E') >*/
  23981.         inde = i_indx(buffer, "E", nlen, 1L);
  23982. /*<       NLEN= NLEN+1 >*/
  23983.         ++nlen;
  23984. /*<       IF( INDE.EQ.0) THEN >*/
  23985.         if (inde == 0) {
  23986. /*<       BUFFER( NLEN: NLEN)='.' >*/
  23987.         buffer[nlen - 1] = '.';
  23988. /*<       ELSE >*/
  23989.         } else {
  23990. /*<       BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1) >*/
  23991. /* Writing concatenation */
  23992.         i__3[0] = indd - 1, a__1[0] = buffer;
  23993.         i__3[1] = 1, a__1[1] = ".";
  23994.         i__3[2] = nlen - 1 - (inde - 1), a__1[2] = buffer + (inde - 1)
  23995.             ;
  23996.         s_cat(buffer1, a__1, i__3, &c__3, 132L);
  23997. /*<       BUFFER= BUFFER1 >*/
  23998.         s_copy(buffer, buffer1, 132L, 132L);
  23999. /*<       ENDIF >*/
  24000.         }
  24001. /*<       ENDIF >*/
  24002.     }
  24003. /*     READ( BUFFER(1: NLEN),112,ERR=110)  RARR( I- NINT) */
  24004. /* 112 format (F15.7) */
  24005. /*<       CALL ATOF(BUFFER,RARR( I- NINT)) >*/
  24006.     atof_(buffer, &rarr[i - 3], 132L);
  24007. /*<   100 CONTINUE >*/
  24008. /* L100: */
  24009.     }
  24010. /*<       I1= IARR(1) >*/
  24011.     *i1 = iarr[0];
  24012. /*<       I2= IARR(2) >*/
  24013.     *i2 = iarr[1];
  24014. /*<       X1= RARR(1) >*/
  24015.     *x1 = rarr[0];
  24016. /*<       Y1= RARR(2) >*/
  24017.     *y1 = rarr[1];
  24018. /*<       Z1= RARR(3) >*/
  24019.     *z1 = rarr[2];
  24020. /*<       X2= RARR(4) >*/
  24021.     *x2 = rarr[3];
  24022. /*<       Y2= RARR(5) >*/
  24023.     *y2 = rarr[4];
  24024. /*<       Z2= RARR(6) >*/
  24025.     *z2 = rarr[5];
  24026. /*<       RAD= RARR(7) >*/
  24027.     *rad = rarr[6];
  24028. /*<       RETURN >*/
  24029.     return 0;
  24030. /*<   110 WRITE( 6,*) ' GEOMETRY DATA CARD ERROR' >*/
  24031. L110:
  24032.     s_wsle(&io___1871);
  24033.     do_lio(&c__9, &c__1, " GEOMETRY DATA CARD ERROR", 25L);
  24034.     e_wsle();
  24035. /*<       WRITE( 6,*)  LINE(1: MAX(1, NLIN-1)) >*/
  24036.     s_wsle(&io___1872);
  24037. /* Computing MAX */
  24038.     i__1 = 1, i__2 = nlin - 1;
  24039.     do_lio(&c__9, &c__1, line, (max(i__1,i__2)));
  24040.     e_wsle();
  24041. /*<       STOP >*/
  24042.     s_stop("", 0L);
  24043. /*<       END >*/
  24044. } /* readgm_ */
  24045.  
  24046. /* *** */
  24047. /*     DOUBLE PRECISION 6/4/85 */
  24048.  
  24049. /*<       SUBROUTINE READMN( GM, I1, I2, I3, I4, F1, F2, F3, F4, F5, F6) >*/
  24050. /* Subroutine */ int readmn_(gm, i1, i2, i3, i4, f1, f2, f3, f4, f5, f6, 
  24051.     gm_len)
  24052. char *gm;
  24053. integer *i1, *i2, *i3, *i4;
  24054. doublereal *f1, *f2, *f3, *f4, *f5, *f6;
  24055. ftnlen gm_len;
  24056. {
  24057.     /* Format strings */
  24058.     static char fmt_10[] = "(a)";
  24059.  
  24060.     /* System generated locals */
  24061.     address a__1[3];
  24062.     integer i__1, i__2, i__3[3];
  24063.  
  24064.     /* Builtin functions */
  24065.     integer s_rsfe(), do_fio(), e_rsfe(), i_len();
  24066.     /* Subroutine */ int s_copy();
  24067.     integer i_indx();
  24068.     /* Subroutine */ int s_cat();
  24069.     integer s_wsle(), do_lio(), e_wsle();
  24070.     /* Subroutine */ int s_stop();
  24071.  
  24072.     /* Local variables */
  24073.     static integer indd, inde;
  24074.     static char line[133];
  24075.     extern /* Subroutine */ int atof_();
  24076.     static integer nlen, iarr[4];
  24077.     extern /* Subroutine */ int atoi_();
  24078.     static integer nlin;
  24079.     static doublereal rarr[6];
  24080.     static integer i;
  24081.     extern /* Subroutine */ int str0pc_();
  24082.     static integer ic, bp[10], ep[10];
  24083.     static char buffer[132];
  24084.     static integer ifound;
  24085.     static char buffer1[132];
  24086.     static integer ind;
  24087.  
  24088.     /* Fortran I/O blocks */
  24089.     static cilist io___1873 = { 0, 5, 0, fmt_10, 0 };
  24090.     static cilist io___1889 = { 0, 6, 0, 0, 0 };
  24091.     static cilist io___1890 = { 0, 6, 0, 0, 0 };
  24092.  
  24093.  
  24094. /* *** */
  24095. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  24096. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  24097. /*<       INTEGER*4 NTOT >*/
  24098. /*<       INTEGER*4 NINT >*/
  24099. /*<       INTEGER*4 NFLT >*/
  24100. /*<       PARAMETER (NTOT=10, NINT=4, NFLT=6) >*/
  24101. /*<       INTEGER  IARR( NINT), BP( NTOT), EP( NTOT) >*/
  24102. /*<       DIMENSION  RARR( NFLT) >*/
  24103. /*<       CHARACTER   LINE*133, GM*2, BUFFER*132, BUFFER1*132 >*/
  24104. /*<       READ( 5,10)  LINE >*/
  24105.     s_rsfe(&io___1873);
  24106.     do_fio(&c__1, line, 133L);
  24107.     e_rsfe();
  24108. /*<    10 FORMAT(A) >*/
  24109. /*<       NLIN= LEN(LINE) >*/
  24110.     nlin = i_len(line, 133L);
  24111. /*<       CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN)) >*/
  24112.     str0pc_(line, line, nlin, nlin);
  24113. /*<       IF( NLIN.LT.2) GOTO 110 >*/
  24114.     if (nlin < 2) {
  24115.     goto L110;
  24116.     }
  24117. /*<       IF( NLIN.LE.132) GOTO 20 >*/
  24118.     if (nlin <= 132) {
  24119.     goto L20;
  24120.     }
  24121. /*<       NLIN=132 >*/
  24122.     nlin = 132;
  24123. /*<       LINE(133:133)=' ' >*/
  24124.     line[132] = ' ';
  24125. /*<    20 GM= LINE(1:2) >*/
  24126. L20:
  24127.     s_copy(gm, line, 2L, 2L);
  24128. /*<       NLIN= NLIN+1 >*/
  24129.     ++nlin;
  24130. /*<       DO 30  I=1, NINT >*/
  24131.     for (i = 1; i <= 4; ++i) {
  24132. /*<    30 IARR( I)=0 >*/
  24133. /* L30: */
  24134.     iarr[i - 1] = 0;
  24135.     }
  24136. /*<       DO 40  I=1, NFLT >*/
  24137.     for (i = 1; i <= 6; ++i) {
  24138. /*<    40 RARR( I)=0.0 >*/
  24139. /* L40: */
  24140.     rarr[i - 1] = 0.;
  24141.     }
  24142. /*<       IC=2 >*/
  24143.     ic = 2;
  24144. /*<       IFOUND=0 >*/
  24145.     ifound = 0;
  24146. /*<       DO 70  I=1, NTOT >*/
  24147.     for (i = 1; i <= 10; ++i) {
  24148. /*<    50 IC= IC+1 >*/
  24149. L50:
  24150.     ++ic;
  24151. /*<       IF( IC.GE. NLIN) GOTO 80 >*/
  24152.     if (ic >= nlin) {
  24153.         goto L80;
  24154.     }
  24155. /*<       IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50 >*/
  24156.     if (line[ic - 1] == ' ' || line[ic - 1] == ',') {
  24157.         goto L50;
  24158.     }
  24159. /* BEGINNING OF I-TH NUMERICAL FIELD */
  24160. /*<       BP( I)= IC >*/
  24161.     bp[i - 1] = ic;
  24162. /*<    60 IC= IC+1 >*/
  24163. L60:
  24164.     ++ic;
  24165. /*<       IF( IC.GT. NLIN) GOTO 80 >*/
  24166.     if (ic > nlin) {
  24167.         goto L80;
  24168.     }
  24169. /*<       IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60 >*/
  24170.     if (line[ic - 1] != ' ' && line[ic - 1] != ',') {
  24171.         goto L60;
  24172.     }
  24173. /* END OF I-TH NUMERICAL FIELD */
  24174. /*<       EP( I)= IC-1 >*/
  24175.     ep[i - 1] = ic - 1;
  24176. /*<       IFOUND= I >*/
  24177.     ifound = i;
  24178. /*<    70 CONTINUE >*/
  24179. /* L70: */
  24180.     }
  24181. /*<    80 CONTINUE >*/
  24182. L80:
  24183. /*<       DO 90  I=1, MIN( IFOUND, NINT) >*/
  24184.     i__1 = min(ifound,4);
  24185.     for (i = 1; i <= i__1; ++i) {
  24186. /*<       NLEN= EP( I)- BP( I)+1 >*/
  24187.     nlen = ep[i - 1] - bp[i - 1] + 1;
  24188. /*<       BUFFER= LINE( BP( I): EP( I)) >*/
  24189.     i__2 = bp[i - 1] - 1;
  24190.     s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
  24191. /*<       IND= INDEX( BUFFER(1: NLEN),'.') >*/
  24192.     ind = i_indx(buffer, ".", nlen, 1L);
  24193. /*<       IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110 >*/
  24194.     if (ind > 0 && ind < nlen) {
  24195.         goto L110;
  24196.     }
  24197. /* USER PUT DECIMAL POINT FOR INTEGER */
  24198. /*<       IF( IND.EQ. NLEN) NLEN= NLEN-1 >*/
  24199.     if (ind == nlen) {
  24200.         --nlen;
  24201.     }
  24202. /*     READ( BUFFER(1: NLEN),111,ERR=110)  IARR( I) */
  24203. /* 111 format(I5) */
  24204. /*<       CALL ATOI(BUFFER,IARR(I)) >*/
  24205.     atoi_(buffer, &iarr[i - 1], 132L);
  24206. /*<    90 CONTINUE >*/
  24207. /* L90: */
  24208.     }
  24209. /*<       DO 100  I= NINT+1, IFOUND >*/
  24210.     i__1 = ifound;
  24211.     for (i = 5; i <= i__1; ++i) {
  24212. /*<       NLEN= EP( I)- BP( I)+1 >*/
  24213.     nlen = ep[i - 1] - bp[i - 1] + 1;
  24214. /*<       BUFFER= LINE( BP( I): EP( I)) >*/
  24215.     i__2 = bp[i - 1] - 1;
  24216.     s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
  24217. /*<       IND= INDEX( BUFFER(1: NLEN),'.') >*/
  24218.     ind = i_indx(buffer, ".", nlen, 1L);
  24219. /* USER FORGOT DECIMAL POINT FOR REAL */
  24220. /*<       IF( IND.EQ.0) THEN >*/
  24221.     if (ind == 0) {
  24222. /*<       IF( NLEN.GE.15) GOTO 110 >*/
  24223.         if (nlen >= 15) {
  24224.         goto L110;
  24225.         }
  24226. /*<       INDE= INDEX( BUFFER(1: NLEN),'E') >*/
  24227.         inde = i_indx(buffer, "E", nlen, 1L);
  24228. /*<       NLEN= NLEN+1 >*/
  24229.         ++nlen;
  24230. /*<       IF( INDE.EQ.0) THEN >*/
  24231.         if (inde == 0) {
  24232. /*<       BUFFER( NLEN: NLEN)='.' >*/
  24233.         buffer[nlen - 1] = '.';
  24234. /*<       ELSE >*/
  24235.         } else {
  24236. /*<       BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1) >*/
  24237. /* Writing concatenation */
  24238.         i__3[0] = indd - 1, a__1[0] = buffer;
  24239.         i__3[1] = 1, a__1[1] = ".";
  24240.         i__3[2] = nlen - 1 - (inde - 1), a__1[2] = buffer + (inde - 1)
  24241.             ;
  24242.         s_cat(buffer1, a__1, i__3, &c__3, 132L);
  24243. /*<       BUFFER= BUFFER1 >*/
  24244.         s_copy(buffer, buffer1, 132L, 132L);
  24245. /*<       ENDIF >*/
  24246.         }
  24247. /*<       ENDIF >*/
  24248.     }
  24249. /*     READ( BUFFER(1: NLEN),112,ERR=110)  RARR( I- NINT) */
  24250. /* 112 format(F15.7) */
  24251. /*<       CALL ATOF(BUFFER,RARR( I- NINT)) >*/
  24252.     atof_(buffer, &rarr[i - 5], 132L);
  24253. /*<   100 CONTINUE >*/
  24254. /* L100: */
  24255.     }
  24256. /*<       I1= IARR(1) >*/
  24257.     *i1 = iarr[0];
  24258. /*<       I2= IARR(2) >*/
  24259.     *i2 = iarr[1];
  24260. /*<       I3= IARR(3) >*/
  24261.     *i3 = iarr[2];
  24262. /*<       I4= IARR(4) >*/
  24263.     *i4 = iarr[3];
  24264. /*<       F1= RARR(1) >*/
  24265.     *f1 = rarr[0];
  24266. /*<       F2= RARR(2) >*/
  24267.     *f2 = rarr[1];
  24268. /*<       F3= RARR(3) >*/
  24269.     *f3 = rarr[2];
  24270. /*<       F4= RARR(4) >*/
  24271.     *f4 = rarr[3];
  24272. /*<       F5= RARR(5) >*/
  24273.     *f5 = rarr[4];
  24274. /*<       F6= RARR(6) >*/
  24275.     *f6 = rarr[5];
  24276. /*<       RETURN >*/
  24277.     return 0;
  24278. /*<   110 WRITE( 6,*) '          FAULTY DATA CARD AFTER GEOMETRY SECTION' >*/
  24279. L110:
  24280.     s_wsle(&io___1889);
  24281.     do_lio(&c__9, &c__1, "          FAULTY DATA CARD AFTER GEOMETRY SECTION", 
  24282.         49L);
  24283.     e_wsle();
  24284. /*<       WRITE( 6,*)  LINE(1: MAX(1, NLIN-1)) >*/
  24285.     s_wsle(&io___1890);
  24286. /* Computing MAX */
  24287.     i__1 = 1, i__2 = nlin - 1;
  24288.     do_lio(&c__9, &c__1, line, (max(i__1,i__2)));
  24289.     e_wsle();
  24290. /*<       STOP >*/
  24291.     s_stop("", 0L);
  24292. /*<       END >*/
  24293. } /* readmn_ */
  24294.  
  24295. /* *** */
  24296. /*     DOUBLE PRECISION 6/4/85 */
  24297.  
  24298. /*<       SUBROUTINE REBLK( B, BX, NB, NBX, N2C) >*/
  24299. /* Subroutine */ int reblk_(b, bx, nb, nbx, n2c)
  24300. doublecomplex *b, *bx;
  24301. integer *nb, *nbx, *n2c;
  24302. {
  24303.     /* System generated locals */
  24304.     integer b_dim1, b_offset, bx_dim1, bx_offset, i__1, i__2, i__3, i__4, 
  24305.         i__5, i__6;
  24306.     alist al__1;
  24307.  
  24308.     /* Builtin functions */
  24309.     integer f_rew(), s_rsue(), do_uio(), e_rsue(), s_wsue(), e_wsue();
  24310.  
  24311.     /* Local variables */
  24312.     static integer i, j, ib, ix, nib, npb, ibx, nix, npx;
  24313.  
  24314.     /* Fortran I/O blocks */
  24315.     static cilist io___1897 = { 0, 14, 0, 0, 0 };
  24316.     static cilist io___1901 = { 0, 16, 0, 0, 0 };
  24317.  
  24318.  
  24319. /* *** */
  24320. /*     REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14 */
  24321.  
  24322. /*     TO BLOCKS OF COLUMNS ON TAPE16 */
  24323. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  24324. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  24325. /*<       COMPLEX  B, BX >*/
  24326. /*<    >*/
  24327. /*<       DIMENSION  B( NB,1), BX( NBX,1) >*/
  24328. /*<       REWIND 16 >*/
  24329.     /* Parameter adjustments */
  24330.     bx_dim1 = *nbx;
  24331.     bx_offset = bx_dim1 + 1;
  24332.     bx -= bx_offset;
  24333.     b_dim1 = *nb;
  24334.     b_offset = b_dim1 + 1;
  24335.     b -= b_offset;
  24336.  
  24337.     /* Function Body */
  24338.     al__1.aerr = 0;
  24339.     al__1.aunit = 16;
  24340.     f_rew(&al__1);
  24341. /*<       NIB=0 >*/
  24342.     nib = 0;
  24343. /*<       NPB= NPBL >*/
  24344.     npb = matpar_1.npbl;
  24345. /*<       DO 3  IB=1, NBBL >*/
  24346.     i__1 = matpar_1.nbbl;
  24347.     for (ib = 1; ib <= i__1; ++ib) {
  24348. /*<       IF( IB.EQ. NBBL) NPB= NLBL >*/
  24349.     if (ib == matpar_1.nbbl) {
  24350.         npb = matpar_1.nlbl;
  24351.     }
  24352. /*<       REWIND 14 >*/
  24353.     al__1.aerr = 0;
  24354.     al__1.aunit = 14;
  24355.     f_rew(&al__1);
  24356. /*<       NIX=0 >*/
  24357.     nix = 0;
  24358. /*<       NPX= NPBX >*/
  24359.     npx = matpar_1.npbx;
  24360. /*<       DO 2  IBX=1, NBBX >*/
  24361.     i__2 = matpar_1.nbbx;
  24362.     for (ibx = 1; ibx <= i__2; ++ibx) {
  24363. /*<       IF( IBX.EQ. NBBX) NPX= NLBX >*/
  24364.         if (ibx == matpar_1.nbbx) {
  24365.         npx = matpar_1.nlbx;
  24366.         }
  24367. /*<       READ( 14) (( BX( I, J), I=1, NPX), J=1, N2C) >*/
  24368.         s_rsue(&io___1897);
  24369.         i__3 = *n2c;
  24370.         for (j = 1; j <= i__3; ++j) {
  24371.         i__4 = npx;
  24372.         for (i = 1; i <= i__4; ++i) {
  24373.             do_uio(&c__2, (char *)&bx[i + j * bx_dim1], (ftnlen)
  24374.                 sizeof(doublereal));
  24375.         }
  24376.         }
  24377.         e_rsue();
  24378. /*<       DO 1  I=1, NPX >*/
  24379.         i__4 = npx;
  24380.         for (i = 1; i <= i__4; ++i) {
  24381. /*<       IX= I+ NIX >*/
  24382.         ix = i + nix;
  24383. /*<       DO 1  J=1, NPB >*/
  24384.         i__3 = npb;
  24385.         for (j = 1; j <= i__3; ++j) {
  24386. /*<     1 B( IX, J)= BX( I, J+ NIB) >*/
  24387. /* L1: */
  24388.             i__5 = ix + j * b_dim1;
  24389.             i__6 = i + (j + nib) * bx_dim1;
  24390.             b[i__5].r = bx[i__6].r, b[i__5].i = bx[i__6].i;
  24391.         }
  24392.         }
  24393. /*<     2 NIX= NIX+ NPBX >*/
  24394. /* L2: */
  24395.         nix += matpar_1.npbx;
  24396.     }
  24397. /*<       WRITE( 16) (( B( I, J), I=1, NB), J=1, NPB) >*/
  24398.     s_wsue(&io___1901);
  24399.     i__2 = npb;
  24400.     for (j = 1; j <= i__2; ++j) {
  24401.         i__5 = *nb;
  24402.         for (i = 1; i <= i__5; ++i) {
  24403.         do_uio(&c__2, (char *)&b[i + j * b_dim1], (ftnlen)sizeof(
  24404.             doublereal));
  24405.         }
  24406.     }
  24407.     e_wsue();
  24408. /*<     3 NIB= NIB+ NPBL >*/
  24409. /* L3: */
  24410.     nib += matpar_1.npbl;
  24411.     }
  24412. /*<       REWIND 14 >*/
  24413.     al__1.aerr = 0;
  24414.     al__1.aunit = 14;
  24415.     f_rew(&al__1);
  24416. /*<       REWIND 16 >*/
  24417.     al__1.aerr = 0;
  24418.     al__1.aunit = 16;
  24419.     f_rew(&al__1);
  24420. /*<       RETURN >*/
  24421.     return 0;
  24422. /*<       END >*/
  24423. } /* reblk_ */
  24424.  
  24425. /* *** */
  24426. /*     DOUBLE PRECISION 6/4/85 */
  24427.  
  24428. /*<       SUBROUTINE REFLC( IX, IY, IZ, ITX, NOP) >*/
  24429. /* Subroutine */ int reflc_(ix, iy, iz, itx, nop)
  24430. integer *ix, *iy, *iz, *itx, *nop;
  24431. {
  24432.     /* Format strings */
  24433.     static char fmt_24[] = "(\002 GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES I\
  24434. N PLANE OF S\002,\002YMMETRY\002)";
  24435.     static char fmt_25[] = "(\002 GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN \
  24436. PLANE OF SYM\002,\002METRY\002)";
  24437.  
  24438.     /* System generated locals */
  24439.     integer i__1;
  24440.     doublereal d__1;
  24441.  
  24442.     /* Builtin functions */
  24443.     integer s_wsfe(), do_fio(), e_wsfe();
  24444.     /* Subroutine */ int s_stop();
  24445.     double cos(), sin();
  24446.  
  24447.     /* Local variables */
  24448.     static doublereal fnop;
  24449.     static integer i, j, k, itagi;
  24450.     static doublereal e1, e2;
  24451. #define x2 ((doublereal *)&data_1 + 1800)
  24452. #define y2 ((doublereal *)&data_1 + 3000)
  24453. #define z2 ((doublereal *)&data_1 + 3600)
  24454.     static doublereal cs, xk, yk;
  24455.     static integer nx;
  24456.     static doublereal ss;
  24457. #define t1x ((doublereal *)&data_1 + 1800)
  24458. #define t1y ((doublereal *)&data_1 + 3000)
  24459. #define t1z ((doublereal *)&data_1 + 3600)
  24460. #define t2x ((doublereal *)&data_1 + 4201)
  24461. #define t2y ((doublereal *)&data_1 + 4601)
  24462. #define t2z ((doublereal *)&data_1 + 5001)
  24463.     static doublereal sam;
  24464.     static integer iti, nxx;
  24465.  
  24466.     /* Fortran I/O blocks */
  24467.     static cilist io___1916 = { 0, 6, 0, fmt_24, 0 };
  24468.     static cilist io___1919 = { 0, 6, 0, fmt_25, 0 };
  24469.     static cilist io___1920 = { 0, 6, 0, fmt_24, 0 };
  24470.     static cilist io___1921 = { 0, 6, 0, fmt_25, 0 };
  24471.     static cilist io___1922 = { 0, 6, 0, fmt_24, 0 };
  24472.     static cilist io___1923 = { 0, 6, 0, fmt_25, 0 };
  24473.  
  24474.  
  24475. /* *** */
  24476.  
  24477. /*     REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES */
  24478.  
  24479. /*     STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE. */
  24480.  
  24481. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  24482. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  24483. /*<    >*/
  24484. /*<       COMMON  /ANGL/ SALP( NM) >*/
  24485. /*<    >*/
  24486. /*<    >*/
  24487. /*<       NP= N >*/
  24488.     data_1.np = data_1.n;
  24489. /*<       MP= M >*/
  24490.     data_1.mp = data_1.m;
  24491. /*<       IPSYM=0 >*/
  24492.     data_1.ipsym = 0;
  24493. /*<       ITI= ITX >*/
  24494.     iti = *itx;
  24495. /*<       IF( IX.LT.0) GOTO 19 >*/
  24496.     if (*ix < 0) {
  24497.     goto L19;
  24498.     }
  24499. /*<       IF( NOP.EQ.0) RETURN >*/
  24500.     if (*nop == 0) {
  24501.     return 0;
  24502.     }
  24503. /*<       IPSYM=1 >*/
  24504.     data_1.ipsym = 1;
  24505.  
  24506. /*     REFLECT ALONG Z AXIS */
  24507.  
  24508. /*<       IF( IZ.EQ.0) GOTO 6 >*/
  24509.     if (*iz == 0) {
  24510.     goto L6;
  24511.     }
  24512. /*<       IPSYM=2 >*/
  24513.     data_1.ipsym = 2;
  24514. /*<       IF( N.LT. N2) GOTO 3 >*/
  24515.     if (data_1.n < data_1.n2) {
  24516.     goto L3;
  24517.     }
  24518. /*<       DO 2  I= N2, N >*/
  24519.     i__1 = data_1.n;
  24520.     for (i = data_1.n2; i <= i__1; ++i) {
  24521. /*<       NX= I+ N- N1 >*/
  24522.     nx = i + data_1.n - data_1.n1;
  24523. /*<       E1= Z( I) >*/
  24524.     e1 = data_1.z[i - 1];
  24525. /*<       E2= Z2( I) >*/
  24526.     e2 = z2[i - 1];
  24527. /*<       IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 1 >*/
  24528.     if (abs(e1) + abs(e2) > 1e-5 && e1 * e2 >= -1e-6) {
  24529.         goto L1;
  24530.     }
  24531. /*<       WRITE( 6,24)  I >*/
  24532.     s_wsfe(&io___1916);
  24533.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  24534.     e_wsfe();
  24535. /*<       STOP >*/
  24536.     s_stop("", 0L);
  24537. /*<     1 X( NX)= X( I) >*/
  24538. L1:
  24539.     data_1.x[nx - 1] = data_1.x[i - 1];
  24540. /*<       Y( NX)= Y( I) >*/
  24541.     data_1.y[nx - 1] = data_1.y[i - 1];
  24542. /*<       Z( NX)=- E1 >*/
  24543.     data_1.z[nx - 1] = -e1;
  24544. /*<       X2( NX)= X2( I) >*/
  24545.     x2[nx - 1] = x2[i - 1];
  24546. /*<       Y2( NX)= Y2( I) >*/
  24547.     y2[nx - 1] = y2[i - 1];
  24548. /*<       Z2( NX)=- E2 >*/
  24549.     z2[nx - 1] = -e2;
  24550. /*<       ITAGI= ITAG( I) >*/
  24551.     itagi = data_1.itag[i - 1];
  24552. /*<       IF( ITAGI.EQ.0) ITAG( NX)=0 >*/
  24553.     if (itagi == 0) {
  24554.         data_1.itag[nx - 1] = 0;
  24555.     }
  24556. /*<       IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI >*/
  24557.     if (itagi != 0) {
  24558.         data_1.itag[nx - 1] = itagi + iti;
  24559.     }
  24560. /*<     2 BI( NX)= BI( I) >*/
  24561. /* L2: */
  24562.     data_1.bi[nx - 1] = data_1.bi[i - 1];
  24563.     }
  24564. /*<       N= N*2- N1 >*/
  24565.     data_1.n = (data_1.n << 1) - data_1.n1;
  24566. /*<       ITI= ITI*2 >*/
  24567.     iti <<= 1;
  24568. /*<     3 IF( M.LT. M2) GOTO 6 >*/
  24569. L3:
  24570.     if (data_1.m < data_1.m2) {
  24571.     goto L6;
  24572.     }
  24573. /*<       NXX= LD+1- M1 >*/
  24574.     nxx = data_1.ld + 1 - data_1.m1;
  24575. /*<       DO 5  I= M2, M >*/
  24576.     i__1 = data_1.m;
  24577.     for (i = data_1.m2; i <= i__1; ++i) {
  24578. /*<       NXX= NXX-1 >*/
  24579.     --nxx;
  24580. /*<       NX= NXX- M+ M1 >*/
  24581.     nx = nxx - data_1.m + data_1.m1;
  24582. /*<       IF( ABS( Z( NXX)).GT.1.D-10) GOTO 4 >*/
  24583.     if ((d__1 = data_1.z[nxx - 1], abs(d__1)) > 1e-10) {
  24584.         goto L4;
  24585.     }
  24586. /*<       WRITE( 6,25)  I >*/
  24587.     s_wsfe(&io___1919);
  24588.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  24589.     e_wsfe();
  24590. /*<       STOP >*/
  24591.     s_stop("", 0L);
  24592. /*<     4 X( NX)= X( NXX) >*/
  24593. L4:
  24594.     data_1.x[nx - 1] = data_1.x[nxx - 1];
  24595. /*<       Y( NX)= Y( NXX) >*/
  24596.     data_1.y[nx - 1] = data_1.y[nxx - 1];
  24597. /*<       Z( NX)=- Z( NXX) >*/
  24598.     data_1.z[nx - 1] = -data_1.z[nxx - 1];
  24599. /*<       T1X( NX)= T1X( NXX) >*/
  24600.     t1x[nx - 1] = t1x[nxx - 1];
  24601. /*<       T1Y( NX)= T1Y( NXX) >*/
  24602.     t1y[nx - 1] = t1y[nxx - 1];
  24603. /*<       T1Z( NX)=- T1Z( NXX) >*/
  24604.     t1z[nx - 1] = -t1z[nxx - 1];
  24605. /*<       T2X( NX)= T2X( NXX) >*/
  24606.     t2x[nx - 1] = t2x[nxx - 1];
  24607. /*<       T2Y( NX)= T2Y( NXX) >*/
  24608.     t2y[nx - 1] = t2y[nxx - 1];
  24609. /*<       T2Z( NX)=- T2Z( NXX) >*/
  24610.     t2z[nx - 1] = -t2z[nxx - 1];
  24611. /*<       SALP( NX)=- SALP( NXX) >*/
  24612.     angl_1.salp[nx - 1] = -angl_1.salp[nxx - 1];
  24613. /*<     5 BI( NX)= BI( NXX) >*/
  24614. /* L5: */
  24615.     data_1.bi[nx - 1] = data_1.bi[nxx - 1];
  24616.     }
  24617. /*<       M= M*2- M1 >*/
  24618.     data_1.m = (data_1.m << 1) - data_1.m1;
  24619.  
  24620. /*     REFLECT ALONG Y AXIS */
  24621.  
  24622. /*<     6 IF( IY.EQ.0) GOTO 12 >*/
  24623. L6:
  24624.     if (*iy == 0) {
  24625.     goto L12;
  24626.     }
  24627. /*<       IF( N.LT. N2) GOTO 9 >*/
  24628.     if (data_1.n < data_1.n2) {
  24629.     goto L9;
  24630.     }
  24631. /*<       DO 8  I= N2, N >*/
  24632.     i__1 = data_1.n;
  24633.     for (i = data_1.n2; i <= i__1; ++i) {
  24634. /*<       NX= I+ N- N1 >*/
  24635.     nx = i + data_1.n - data_1.n1;
  24636. /*<       E1= Y( I) >*/
  24637.     e1 = data_1.y[i - 1];
  24638. /*<       E2= Y2( I) >*/
  24639.     e2 = y2[i - 1];
  24640. /*<       IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 7 >*/
  24641.     if (abs(e1) + abs(e2) > 1e-5 && e1 * e2 >= -1e-6) {
  24642.         goto L7;
  24643.     }
  24644. /*<       WRITE( 6,24)  I >*/
  24645.     s_wsfe(&io___1920);
  24646.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  24647.     e_wsfe();
  24648. /*<       STOP >*/
  24649.     s_stop("", 0L);
  24650. /*<     7 X( NX)= X( I) >*/
  24651. L7:
  24652.     data_1.x[nx - 1] = data_1.x[i - 1];
  24653. /*<       Y( NX)=- E1 >*/
  24654.     data_1.y[nx - 1] = -e1;
  24655. /*<       Z( NX)= Z( I) >*/
  24656.     data_1.z[nx - 1] = data_1.z[i - 1];
  24657. /*<       X2( NX)= X2( I) >*/
  24658.     x2[nx - 1] = x2[i - 1];
  24659. /*<       Y2( NX)=- E2 >*/
  24660.     y2[nx - 1] = -e2;
  24661. /*<       Z2( NX)= Z2( I) >*/
  24662.     z2[nx - 1] = z2[i - 1];
  24663. /*<       ITAGI= ITAG( I) >*/
  24664.     itagi = data_1.itag[i - 1];
  24665. /*<       IF( ITAGI.EQ.0) ITAG( NX)=0 >*/
  24666.     if (itagi == 0) {
  24667.         data_1.itag[nx - 1] = 0;
  24668.     }
  24669. /*<       IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI >*/
  24670.     if (itagi != 0) {
  24671.         data_1.itag[nx - 1] = itagi + iti;
  24672.     }
  24673. /*<     8 BI( NX)= BI( I) >*/
  24674. /* L8: */
  24675.     data_1.bi[nx - 1] = data_1.bi[i - 1];
  24676.     }
  24677. /*<       N= N*2- N1 >*/
  24678.     data_1.n = (data_1.n << 1) - data_1.n1;
  24679. /*<       ITI= ITI*2 >*/
  24680.     iti <<= 1;
  24681. /*<     9 IF( M.LT. M2) GOTO 12 >*/
  24682. L9:
  24683.     if (data_1.m < data_1.m2) {
  24684.     goto L12;
  24685.     }
  24686. /*<       NXX= LD+1- M1 >*/
  24687.     nxx = data_1.ld + 1 - data_1.m1;
  24688. /*<       DO 11  I= M2, M >*/
  24689.     i__1 = data_1.m;
  24690.     for (i = data_1.m2; i <= i__1; ++i) {
  24691. /*<       NXX= NXX-1 >*/
  24692.     --nxx;
  24693. /*<       NX= NXX- M+ M1 >*/
  24694.     nx = nxx - data_1.m + data_1.m1;
  24695. /*<       IF( ABS( Y( NXX)).GT.1.D-10) GOTO 10 >*/
  24696.     if ((d__1 = data_1.y[nxx - 1], abs(d__1)) > 1e-10) {
  24697.         goto L10;
  24698.     }
  24699. /*<       WRITE( 6,25)  I >*/
  24700.     s_wsfe(&io___1921);
  24701.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  24702.     e_wsfe();
  24703. /*<       STOP >*/
  24704.     s_stop("", 0L);
  24705. /*<    10 X( NX)= X( NXX) >*/
  24706. L10:
  24707.     data_1.x[nx - 1] = data_1.x[nxx - 1];
  24708. /*<       Y( NX)=- Y( NXX) >*/
  24709.     data_1.y[nx - 1] = -data_1.y[nxx - 1];
  24710. /*<       Z( NX)= Z( NXX) >*/
  24711.     data_1.z[nx - 1] = data_1.z[nxx - 1];
  24712. /*<       T1X( NX)= T1X( NXX) >*/
  24713.     t1x[nx - 1] = t1x[nxx - 1];
  24714. /*<       T1Y( NX)=- T1Y( NXX) >*/
  24715.     t1y[nx - 1] = -t1y[nxx - 1];
  24716. /*<       T1Z( NX)= T1Z( NXX) >*/
  24717.     t1z[nx - 1] = t1z[nxx - 1];
  24718. /*<       T2X( NX)= T2X( NXX) >*/
  24719.     t2x[nx - 1] = t2x[nxx - 1];
  24720. /*<       T2Y( NX)=- T2Y( NXX) >*/
  24721.     t2y[nx - 1] = -t2y[nxx - 1];
  24722. /*<       T2Z( NX)= T2Z( NXX) >*/
  24723.     t2z[nx - 1] = t2z[nxx - 1];
  24724. /*<       SALP( NX)=- SALP( NXX) >*/
  24725.     angl_1.salp[nx - 1] = -angl_1.salp[nxx - 1];
  24726. /*<    11 BI( NX)= BI( NXX) >*/
  24727. /* L11: */
  24728.     data_1.bi[nx - 1] = data_1.bi[nxx - 1];
  24729.     }
  24730. /*<       M= M*2- M1 >*/
  24731.     data_1.m = (data_1.m << 1) - data_1.m1;
  24732.  
  24733. /*     REFLECT ALONG X AXIS */
  24734.  
  24735. /*<    12 IF( IX.EQ.0) GOTO 18 >*/
  24736. L12:
  24737.     if (*ix == 0) {
  24738.     goto L18;
  24739.     }
  24740. /*<       IF( N.LT. N2) GOTO 15 >*/
  24741.     if (data_1.n < data_1.n2) {
  24742.     goto L15;
  24743.     }
  24744. /*<       DO 14  I= N2, N >*/
  24745.     i__1 = data_1.n;
  24746.     for (i = data_1.n2; i <= i__1; ++i) {
  24747. /*<       NX= I+ N- N1 >*/
  24748.     nx = i + data_1.n - data_1.n1;
  24749. /*<       E1= X( I) >*/
  24750.     e1 = data_1.x[i - 1];
  24751. /*<       E2= X2( I) >*/
  24752.     e2 = x2[i - 1];
  24753. /*<       IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 13 >*/
  24754.     if (abs(e1) + abs(e2) > 1e-5 && e1 * e2 >= -1e-6) {
  24755.         goto L13;
  24756.     }
  24757. /*<       WRITE( 6,24)  I >*/
  24758.     s_wsfe(&io___1922);
  24759.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  24760.     e_wsfe();
  24761. /*<       STOP >*/
  24762.     s_stop("", 0L);
  24763. /*<    13 X( NX)=- E1 >*/
  24764. L13:
  24765.     data_1.x[nx - 1] = -e1;
  24766. /*<       Y( NX)= Y( I) >*/
  24767.     data_1.y[nx - 1] = data_1.y[i - 1];
  24768. /*<       Z( NX)= Z( I) >*/
  24769.     data_1.z[nx - 1] = data_1.z[i - 1];
  24770. /*<       X2( NX)=- E2 >*/
  24771.     x2[nx - 1] = -e2;
  24772. /*<       Y2( NX)= Y2( I) >*/
  24773.     y2[nx - 1] = y2[i - 1];
  24774. /*<       Z2( NX)= Z2( I) >*/
  24775.     z2[nx - 1] = z2[i - 1];
  24776. /*<       ITAGI= ITAG( I) >*/
  24777.     itagi = data_1.itag[i - 1];
  24778. /*<       IF( ITAGI.EQ.0) ITAG( NX)=0 >*/
  24779.     if (itagi == 0) {
  24780.         data_1.itag[nx - 1] = 0;
  24781.     }
  24782. /*<       IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI >*/
  24783.     if (itagi != 0) {
  24784.         data_1.itag[nx - 1] = itagi + iti;
  24785.     }
  24786. /*<    14 BI( NX)= BI( I) >*/
  24787. /* L14: */
  24788.     data_1.bi[nx - 1] = data_1.bi[i - 1];
  24789.     }
  24790. /*<       N= N*2- N1 >*/
  24791.     data_1.n = (data_1.n << 1) - data_1.n1;
  24792. /*<    15 IF( M.LT. M2) GOTO 18 >*/
  24793. L15:
  24794.     if (data_1.m < data_1.m2) {
  24795.     goto L18;
  24796.     }
  24797. /*<       NXX= LD+1- M1 >*/
  24798.     nxx = data_1.ld + 1 - data_1.m1;
  24799. /*<       DO 17  I= M2, M >*/
  24800.     i__1 = data_1.m;
  24801.     for (i = data_1.m2; i <= i__1; ++i) {
  24802. /*<       NXX= NXX-1 >*/
  24803.     --nxx;
  24804. /*<       NX= NXX- M+ M1 >*/
  24805.     nx = nxx - data_1.m + data_1.m1;
  24806. /*<       IF( ABS( X( NXX)).GT.1.D-10) GOTO 16 >*/
  24807.     if ((d__1 = data_1.x[nxx - 1], abs(d__1)) > 1e-10) {
  24808.         goto L16;
  24809.     }
  24810. /*<       WRITE( 6,25)  I >*/
  24811.     s_wsfe(&io___1923);
  24812.     do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
  24813.     e_wsfe();
  24814. /*<       STOP >*/
  24815.     s_stop("", 0L);
  24816. /*<    16 X( NX)=- X( NXX) >*/
  24817. L16:
  24818.     data_1.x[nx - 1] = -data_1.x[nxx - 1];
  24819. /*<       Y( NX)= Y( NXX) >*/
  24820.     data_1.y[nx - 1] = data_1.y[nxx - 1];
  24821. /*<       Z( NX)= Z( NXX) >*/
  24822.     data_1.z[nx - 1] = data_1.z[nxx - 1];
  24823. /*<       T1X( NX)=- T1X( NXX) >*/
  24824.     t1x[nx - 1] = -t1x[nxx - 1];
  24825. /*<       T1Y( NX)= T1Y( NXX) >*/
  24826.     t1y[nx - 1] = t1y[nxx - 1];
  24827. /*<       T1Z( NX)= T1Z( NXX) >*/
  24828.     t1z[nx - 1] = t1z[nxx - 1];
  24829. /*<       T2X( NX)=- T2X( NXX) >*/
  24830.     t2x[nx - 1] = -t2x[nxx - 1];
  24831. /*<       T2Y( NX)= T2Y( NXX) >*/
  24832.     t2y[nx - 1] = t2y[nxx - 1];
  24833. /*<       T2Z( NX)= T2Z( NXX) >*/
  24834.     t2z[nx - 1] = t2z[nxx - 1];
  24835. /*<       SALP( NX)=- SALP( NXX) >*/
  24836.     angl_1.salp[nx - 1] = -angl_1.salp[nxx - 1];
  24837. /*<    17 BI( NX)= BI( NXX) >*/
  24838. /* L17: */
  24839.     data_1.bi[nx - 1] = data_1.bi[nxx - 1];
  24840.     }
  24841. /*<       M= M*2- M1 >*/
  24842.     data_1.m = (data_1.m << 1) - data_1.m1;
  24843.  
  24844. /*     REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE */
  24845.  
  24846. /*<    18 RETURN >*/
  24847. L18:
  24848.     return 0;
  24849. /*<    19 FNOP= NOP >*/
  24850. L19:
  24851.     fnop = (doublereal) (*nop);
  24852. /*<       IPSYM=-1 >*/
  24853.     data_1.ipsym = -1;
  24854. /*<       SAM=6.283185308D+0/ FNOP >*/
  24855.     sam = 6.283185308 / fnop;
  24856. /*<       CS= COS( SAM) >*/
  24857.     cs = cos(sam);
  24858. /*<       SS= SIN( SAM) >*/
  24859.     ss = sin(sam);
  24860. /*<       IF( N.LT. N2) GOTO 21 >*/
  24861.     if (data_1.n < data_1.n2) {
  24862.     goto L21;
  24863.     }
  24864. /*<       N= N1+( N- N1)* NOP >*/
  24865.     data_1.n = data_1.n1 + (data_1.n - data_1.n1) * *nop;
  24866. /*<       NX= NP+1 >*/
  24867.     nx = data_1.np + 1;
  24868. /*<       DO 20  I= NX, N >*/
  24869.     i__1 = data_1.n;
  24870.     for (i = nx; i <= i__1; ++i) {
  24871. /*<       K= I- NP+ N1 >*/
  24872.     k = i - data_1.np + data_1.n1;
  24873. /*<       XK= X( K) >*/
  24874.     xk = data_1.x[k - 1];
  24875. /*<       YK= Y( K) >*/
  24876.     yk = data_1.y[k - 1];
  24877. /*<       X( I)= XK* CS- YK* SS >*/
  24878.     data_1.x[i - 1] = xk * cs - yk * ss;
  24879. /*<       Y( I)= XK* SS+ YK* CS >*/
  24880.     data_1.y[i - 1] = xk * ss + yk * cs;
  24881. /*<       Z( I)= Z( K) >*/
  24882.     data_1.z[i - 1] = data_1.z[k - 1];
  24883. /*<       XK= X2( K) >*/
  24884.     xk = x2[k - 1];
  24885. /*<       YK= Y2( K) >*/
  24886.     yk = y2[k - 1];
  24887. /*<       X2( I)= XK* CS- YK* SS >*/
  24888.     x2[i - 1] = xk * cs - yk * ss;
  24889. /*<       Y2( I)= XK* SS+ YK* CS >*/
  24890.     y2[i - 1] = xk * ss + yk * cs;
  24891. /*<       Z2( I)= Z2( K) >*/
  24892.     z2[i - 1] = z2[k - 1];
  24893. /*<       ITAGI= ITAG( K) >*/
  24894.     itagi = data_1.itag[k - 1];
  24895. /*<       IF( ITAGI.EQ.0) ITAG( I)=0 >*/
  24896.     if (itagi == 0) {
  24897.         data_1.itag[i - 1] = 0;
  24898.     }
  24899. /*<       IF( ITAGI.NE.0) ITAG( I)= ITAGI+ ITI >*/
  24900.     if (itagi != 0) {
  24901.         data_1.itag[i - 1] = itagi + iti;
  24902.     }
  24903. /*<    20 BI( I)= BI( K) >*/
  24904. /* L20: */
  24905.     data_1.bi[i - 1] = data_1.bi[k - 1];
  24906.     }
  24907. /*<    21 IF( M.LT. M2) GOTO 23 >*/
  24908. L21:
  24909.     if (data_1.m < data_1.m2) {
  24910.     goto L23;
  24911.     }
  24912. /*<       M= M1+( M- M1)* NOP >*/
  24913.     data_1.m = data_1.m1 + (data_1.m - data_1.m1) * *nop;
  24914. /*<       NX= MP+1 >*/
  24915.     nx = data_1.mp + 1;
  24916. /*<       K= LD+1- M1 >*/
  24917.     k = data_1.ld + 1 - data_1.m1;
  24918. /*<       DO 22  I= NX, M >*/
  24919.     i__1 = data_1.m;
  24920.     for (i = nx; i <= i__1; ++i) {
  24921. /*<       K= K-1 >*/
  24922.     --k;
  24923. /*<       J= K- MP+ M1 >*/
  24924.     j = k - data_1.mp + data_1.m1;
  24925. /*<       XK= X( K) >*/
  24926.     xk = data_1.x[k - 1];
  24927. /*<       YK= Y( K) >*/
  24928.     yk = data_1.y[k - 1];
  24929. /*<       X( J)= XK* CS- YK* SS >*/
  24930.     data_1.x[j - 1] = xk * cs - yk * ss;
  24931. /*<       Y( J)= XK* SS+ YK* CS >*/
  24932.     data_1.y[j - 1] = xk * ss + yk * cs;
  24933. /*<       Z( J)= Z( K) >*/
  24934.     data_1.z[j - 1] = data_1.z[k - 1];
  24935. /*<       XK= T1X( K) >*/
  24936.     xk = t1x[k - 1];
  24937. /*<       YK= T1Y( K) >*/
  24938.     yk = t1y[k - 1];
  24939. /*<       T1X( J)= XK* CS- YK* SS >*/
  24940.     t1x[j - 1] = xk * cs - yk * ss;
  24941. /*<       T1Y( J)= XK* SS+ YK* CS >*/
  24942.     t1y[j - 1] = xk * ss + yk * cs;
  24943. /*<       T1Z( J)= T1Z( K) >*/
  24944.     t1z[j - 1] = t1z[k - 1];
  24945. /*<       XK= T2X( K) >*/
  24946.     xk = t2x[k - 1];
  24947. /*<       YK= T2Y( K) >*/
  24948.     yk = t2y[k - 1];
  24949. /*<       T2X( J)= XK* CS- YK* SS >*/
  24950.     t2x[j - 1] = xk * cs - yk * ss;
  24951. /*<       T2Y( J)= XK* SS+ YK* CS >*/
  24952.     t2y[j - 1] = xk * ss + yk * cs;
  24953. /*<       T2Z( J)= T2Z( K) >*/
  24954.     t2z[j - 1] = t2z[k - 1];
  24955. /*<       SALP( J)= SALP( K) >*/
  24956.     angl_1.salp[j - 1] = angl_1.salp[k - 1];
  24957. /*<    22 BI( J)= BI( K) >*/
  24958. /* L22: */
  24959.     data_1.bi[j - 1] = data_1.bi[k - 1];
  24960.     }
  24961.  
  24962. /*<    23 RETURN >*/
  24963. L23:
  24964.     return 0;
  24965. /*<    >*/
  24966. /*<    >*/
  24967. /*<       END >*/
  24968. } /* reflc_ */
  24969.  
  24970. #undef t2z
  24971. #undef t2y
  24972. #undef t2x
  24973. #undef t1z
  24974. #undef t1y
  24975. #undef t1x
  24976. #undef z2
  24977. #undef y2
  24978. #undef x2
  24979.  
  24980.  
  24981. /* *** */
  24982. /*     DOUBLE PRECISION 6/4/85 */
  24983.  
  24984. /*<       SUBROUTINE ROM2( A, B, SUM, DMIN) >*/
  24985. /* Subroutine */ int rom2_(a, b, sum, dmin_)
  24986. doublereal *a, *b;
  24987. doublecomplex *sum;
  24988. doublereal *dmin_;
  24989. {
  24990.     /* Initialized data */
  24991.  
  24992.     static integer nm = 65536;
  24993.     static integer nts = 4;
  24994.     static integer nx = 1;
  24995.     static integer n = 9;
  24996.     static doublereal rx = 1e-4;
  24997.  
  24998.     /* Format strings */
  24999.     static char fmt_18[] = "(\002 ERROR - B LESS THAN A IN ROM2\002)";
  25000.     static char fmt_19[] = "(\002 ROM2 -- STEP SIZE LIMITED AT Z =\002,1p,e1\
  25001. 2.5)";
  25002.  
  25003.     /* System generated locals */
  25004.     integer i__1, i__2, i__3, i__4;
  25005.     doublereal d__1;
  25006.     doublecomplex z__1, z__2, z__3, z__4;
  25007.  
  25008.     /* Builtin functions */
  25009.     integer s_wsfe(), e_wsfe();
  25010.     /* Subroutine */ int s_stop();
  25011.     double d_imag(), sqrt();
  25012.     integer do_fio();
  25013.  
  25014.     /* Local variables */
  25015.     static doublereal zend;
  25016.     extern /* Subroutine */ int test_();
  25017.     static doublereal dzot, tmag1, tmag2;
  25018.     static integer i;
  25019.     static doublereal s, z;
  25020.     extern /* Subroutine */ int sflds_();
  25021.     static doublecomplex g1[9], g2[9], g3[9], g4[9], g5[9], t00, t01[9], t10[
  25022.         9], t02, t11, t20[9];
  25023.     static doublereal ep, ti, dz, ze;
  25024.     static integer ns, nt;
  25025.     static doublereal tr;
  25026.  
  25027.     /* Fortran I/O blocks */
  25028.     static cilist io___1940 = { 0, 6, 0, fmt_18, 0 };
  25029.     static cilist io___1963 = { 0, 6, 0, fmt_19, 0 };
  25030.  
  25031.  
  25032. /* *** */
  25033.  
  25034. /*     FOR THE SOMMERFELD GROUND OPTION, ROM2 INTEGRATES OVER THE SOURCE 
  25035. */
  25036. /*     SEGMENT TO OBTAIN THE TOTAL FIELD DUE TO GROUND.  THE METHOD OF */
  25037. /*     VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED.  THERE ARE 9 
  25038. */
  25039. /*     FIELD COMPONENTS - THE X, Y, AND Z COMPONENTS DUE TO CONSTANT, */
  25040. /*     SINE, AND COSINE CURRENT DISTRIBUTIONS. */
  25041.  
  25042. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  25043. /*<    >*/
  25044. /*<    >*/
  25045. /*<       DATA   NM, NTS, NX, N/65536,4,1,9/, RX/1.D-4/ >*/
  25046.     /* Parameter adjustments */
  25047.     --sum;
  25048.  
  25049.     /* Function Body */
  25050. /*<       Z= A >*/
  25051.     z = *a;
  25052. /*<       ZE= B >*/
  25053.     ze = *b;
  25054. /*<       S= B- A >*/
  25055.     s = *b - *a;
  25056. /*<       IF( S.GE.0.) GOTO 1 >*/
  25057.     if (s >= 0.) {
  25058.     goto L1;
  25059.     }
  25060. /*<       WRITE( 6,18)  >*/
  25061.     s_wsfe(&io___1940);
  25062.     e_wsfe();
  25063. /*<       STOP >*/
  25064.     s_stop("", 0L);
  25065. /*<     1 EP= S/(1.E4* NM) >*/
  25066. L1:
  25067.     ep = s / (nm * 1e4);
  25068. /*<       ZEND= ZE- EP >*/
  25069.     zend = ze - ep;
  25070. /*<       DO 2  I=1, N >*/
  25071.     i__1 = n;
  25072.     for (i = 1; i <= i__1; ++i) {
  25073. /*<     2 SUM( I)=(0.,0.) >*/
  25074. /* L2: */
  25075.     i__2 = i;
  25076.     sum[i__2].r = 0., sum[i__2].i = 0.;
  25077.     }
  25078. /*<       NS= NX >*/
  25079.     ns = nx;
  25080. /*<       NT=0 >*/
  25081.     nt = 0;
  25082. /*<       CALL SFLDS( Z, G1) >*/
  25083.     sflds_(&z, g1);
  25084. /*<     3 DZ= S/ NS >*/
  25085. L3:
  25086.     dz = s / ns;
  25087. /*<       IF( Z+ DZ.LE. ZE) GOTO 4 >*/
  25088.     if (z + dz <= ze) {
  25089.     goto L4;
  25090.     }
  25091. /*<       DZ= ZE- Z >*/
  25092.     dz = ze - z;
  25093. /*<       IF( DZ.LE. EP) GOTO 17 >*/
  25094.     if (dz <= ep) {
  25095.     goto L17;
  25096.     }
  25097. /*<     4 DZOT= DZ*.5 >*/
  25098. L4:
  25099.     dzot = dz * .5;
  25100. /*<       CALL SFLDS( Z+ DZOT, G3) >*/
  25101.     d__1 = z + dzot;
  25102.     sflds_(&d__1, g3);
  25103. /*<       CALL SFLDS( Z+ DZ, G5) >*/
  25104.     d__1 = z + dz;
  25105.     sflds_(&d__1, g5);
  25106. /*<     5 TMAG1=0. >*/
  25107. L5:
  25108.     tmag1 = 0.;
  25109.  
  25110. /*     EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE. */
  25111.  
  25112. /*<       TMAG2=0. >*/
  25113.     tmag2 = 0.;
  25114. /*<       DO 6  I=1, N >*/
  25115.     i__2 = n;
  25116.     for (i = 1; i <= i__2; ++i) {
  25117. /*<       T00=( G1( I)+ G5( I))* DZOT >*/
  25118.     i__1 = i - 1;
  25119.     i__3 = i - 1;
  25120.     z__2.r = g1[i__1].r + g5[i__3].r, z__2.i = g1[i__1].i + g5[i__3].i;
  25121.     z__1.r = dzot * z__2.r, z__1.i = dzot * z__2.i;
  25122.     t00.r = z__1.r, t00.i = z__1.i;
  25123. /*<       T01( I)=( T00+ DZ* G3( I))*.5 >*/
  25124.     i__1 = i - 1;
  25125.     i__3 = i - 1;
  25126.     z__3.r = dz * g3[i__3].r, z__3.i = dz * g3[i__3].i;
  25127.     z__2.r = t00.r + z__3.r, z__2.i = t00.i + z__3.i;
  25128.     z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
  25129.     t01[i__1].r = z__1.r, t01[i__1].i = z__1.i;
  25130. /*<       T10( I)=(4.* T01( I)- T00)/3. >*/
  25131.     i__1 = i - 1;
  25132.     i__3 = i - 1;
  25133.     z__3.r = t01[i__3].r * 4., z__3.i = t01[i__3].i * 4.;
  25134.     z__2.r = z__3.r - t00.r, z__2.i = z__3.i - t00.i;
  25135.     z__1.r = z__2.r / 3., z__1.i = z__2.i / 3.;
  25136.     t10[i__1].r = z__1.r, t10[i__1].i = z__1.i;
  25137. /*<       IF( I.GT.3) GOTO 6 >*/
  25138.     if (i > 3) {
  25139.         goto L6;
  25140.     }
  25141. /*<       TR= REAL( T01( I)) >*/
  25142.     i__1 = i - 1;
  25143.     tr = t01[i__1].r;
  25144. /*<       TI= AIMAG( T01( I)) >*/
  25145.     ti = d_imag(&t01[i - 1]);
  25146. /*<       TMAG1= TMAG1+ TR* TR+ TI* TI >*/
  25147.     d__1 = tmag1 + tr * tr;
  25148.     tmag1 = d__1 + ti * ti;
  25149. /*<       TR= REAL( T10( I)) >*/
  25150.     i__1 = i - 1;
  25151.     tr = t10[i__1].r;
  25152. /*<       TI= AIMAG( T10( I)) >*/
  25153.     ti = d_imag(&t10[i - 1]);
  25154. /*<       TMAG2= TMAG2+ TR* TR+ TI* TI >*/
  25155.     d__1 = tmag2 + tr * tr;
  25156.     tmag2 = d__1 + ti * ti;
  25157. /*<     6 CONTINUE >*/
  25158. L6:
  25159.     ;
  25160.     }
  25161. /*<       TMAG1= SQRT( TMAG1) >*/
  25162.     tmag1 = sqrt(tmag1);
  25163. /*<       TMAG2= SQRT( TMAG2) >*/
  25164.     tmag2 = sqrt(tmag2);
  25165. /*<       CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN) >*/
  25166.     test_(&tmag1, &tmag2, &tr, &c_b594, &c_b594, &ti, dmin_);
  25167. /*<       IF( TR.GT. RX) GOTO 8 >*/
  25168.     if (tr > rx) {
  25169.     goto L8;
  25170.     }
  25171. /*<       DO 7  I=1, N >*/
  25172.     i__2 = n;
  25173.     for (i = 1; i <= i__2; ++i) {
  25174. /*<     7 SUM( I)= SUM( I)+ T10( I) >*/
  25175. /* L7: */
  25176.     i__1 = i;
  25177.     i__3 = i;
  25178.     i__4 = i - 1;
  25179.     z__1.r = sum[i__3].r + t10[i__4].r, z__1.i = sum[i__3].i + t10[i__4]
  25180.         .i;
  25181.     sum[i__1].r = z__1.r, sum[i__1].i = z__1.i;
  25182.     }
  25183. /*<       NT= NT+2 >*/
  25184.     nt += 2;
  25185. /*<       GOTO 12 >*/
  25186.     goto L12;
  25187. /*<     8 CALL SFLDS( Z+ DZ*.25, G2) >*/
  25188. L8:
  25189.     d__1 = z + dz * .25;
  25190.     sflds_(&d__1, g2);
  25191. /*<       CALL SFLDS( Z+ DZ*.75, G4) >*/
  25192.     d__1 = z + dz * .75;
  25193.     sflds_(&d__1, g4);
  25194. /*<       TMAG1=0. >*/
  25195.     tmag1 = 0.;
  25196.  
  25197. /*     EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE. */
  25198.  
  25199. /*<       TMAG2=0. >*/
  25200.     tmag2 = 0.;
  25201. /*<       DO 9  I=1, N >*/
  25202.     i__1 = n;
  25203.     for (i = 1; i <= i__1; ++i) {
  25204. /*<       T02=( T01( I)+ DZOT*( G2( I)+ G4( I)))*.5 >*/
  25205.     i__3 = i - 1;
  25206.     i__4 = i - 1;
  25207.     i__2 = i - 1;
  25208.     z__4.r = g2[i__4].r + g4[i__2].r, z__4.i = g2[i__4].i + g4[i__2].i;
  25209.     z__3.r = dzot * z__4.r, z__3.i = dzot * z__4.i;
  25210.     z__2.r = t01[i__3].r + z__3.r, z__2.i = t01[i__3].i + z__3.i;
  25211.     z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
  25212.     t02.r = z__1.r, t02.i = z__1.i;
  25213. /*<       T11=(4.* T02- T01( I))/3. >*/
  25214.     z__3.r = t02.r * 4., z__3.i = t02.i * 4.;
  25215.     i__3 = i - 1;
  25216.     z__2.r = z__3.r - t01[i__3].r, z__2.i = z__3.i - t01[i__3].i;
  25217.     z__1.r = z__2.r / 3., z__1.i = z__2.i / 3.;
  25218.     t11.r = z__1.r, t11.i = z__1.i;
  25219. /*<       T20( I)=(16.* T11- T10( I))/15. >*/
  25220.     i__3 = i - 1;
  25221.     z__3.r = t11.r * 16., z__3.i = t11.i * 16.;
  25222.     i__4 = i - 1;
  25223.     z__2.r = z__3.r - t10[i__4].r, z__2.i = z__3.i - t10[i__4].i;
  25224.     z__1.r = z__2.r / 15., z__1.i = z__2.i / 15.;
  25225.     t20[i__3].r = z__1.r, t20[i__3].i = z__1.i;
  25226. /*<       IF( I.GT.3) GOTO 9 >*/
  25227.     if (i > 3) {
  25228.         goto L9;
  25229.     }
  25230. /*<       TR= REAL( T11) >*/
  25231.     tr = t11.r;
  25232. /*<       TI= AIMAG( T11) >*/
  25233.     ti = d_imag(&t11);
  25234. /*<       TMAG1= TMAG1+ TR* TR+ TI* TI >*/
  25235.     d__1 = tmag1 + tr * tr;
  25236.     tmag1 = d__1 + ti * ti;
  25237. /*<       TR= REAL( T20( I)) >*/
  25238.     i__3 = i - 1;
  25239.     tr = t20[i__3].r;
  25240. /*<       TI= AIMAG( T20( I)) >*/
  25241.     ti = d_imag(&t20[i - 1]);
  25242. /*<       TMAG2= TMAG2+ TR* TR+ TI* TI >*/
  25243.     d__1 = tmag2 + tr * tr;
  25244.     tmag2 = d__1 + ti * ti;
  25245. /*<     9 CONTINUE >*/
  25246. L9:
  25247.     ;
  25248.     }
  25249. /*<       TMAG1= SQRT( TMAG1) >*/
  25250.     tmag1 = sqrt(tmag1);
  25251. /*<       TMAG2= SQRT( TMAG2) >*/
  25252.     tmag2 = sqrt(tmag2);
  25253. /*<       CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN) >*/
  25254.     test_(&tmag1, &tmag2, &tr, &c_b594, &c_b594, &ti, dmin_);
  25255. /*<       IF( TR.GT. RX) GOTO 14 >*/
  25256.     if (tr > rx) {
  25257.     goto L14;
  25258.     }
  25259. /*<    10 DO 11  I=1, N >*/
  25260. L10:
  25261.     i__1 = n;
  25262.     for (i = 1; i <= i__1; ++i) {
  25263. /*<    11 SUM( I)= SUM( I)+ T20( I) >*/
  25264. /* L11: */
  25265.     i__3 = i;
  25266.     i__4 = i;
  25267.     i__2 = i - 1;
  25268.     z__1.r = sum[i__4].r + t20[i__2].r, z__1.i = sum[i__4].i + t20[i__2]
  25269.         .i;
  25270.     sum[i__3].r = z__1.r, sum[i__3].i = z__1.i;
  25271.     }
  25272. /*<       NT= NT+1 >*/
  25273.     ++nt;
  25274. /*<    12 Z= Z+ DZ >*/
  25275. L12:
  25276.     z += dz;
  25277. /*<       IF( Z.GT. ZEND) GOTO 17 >*/
  25278.     if (z > zend) {
  25279.     goto L17;
  25280.     }
  25281. /*<       DO 13  I=1, N >*/
  25282.     i__3 = n;
  25283.     for (i = 1; i <= i__3; ++i) {
  25284. /*<    13 G1( I)= G5( I) >*/
  25285. /* L13: */
  25286.     i__4 = i - 1;
  25287.     i__2 = i - 1;
  25288.     g1[i__4].r = g5[i__2].r, g1[i__4].i = g5[i__2].i;
  25289.     }
  25290. /*<       IF( NT.LT. NTS.OR. NS.LE. NX) GOTO 3 >*/
  25291.     if (nt < nts || ns <= nx) {
  25292.     goto L3;
  25293.     }
  25294. /*<       NS= NS/2 >*/
  25295.     ns /= 2;
  25296. /*<       NT=1 >*/
  25297.     nt = 1;
  25298. /*<       GOTO 3 >*/
  25299.     goto L3;
  25300. /*<    14 NT=0 >*/
  25301. L14:
  25302.     nt = 0;
  25303. /*<       IF( NS.LT. NM) GOTO 15 >*/
  25304.     if (ns < nm) {
  25305.     goto L15;
  25306.     }
  25307. /*<       WRITE( 6,19)  Z >*/
  25308.     s_wsfe(&io___1963);
  25309.     do_fio(&c__1, (char *)&z, (ftnlen)sizeof(doublereal));
  25310.     e_wsfe();
  25311. /*<       GOTO 10 >*/
  25312.     goto L10;
  25313. /*<    15 NS= NS*2 >*/
  25314. L15:
  25315.     ns <<= 1;
  25316. /*<       DZ= S/ NS >*/
  25317.     dz = s / ns;
  25318. /*<       DZOT= DZ*.5 >*/
  25319.     dzot = dz * .5;
  25320. /*<       DO 16  I=1, N >*/
  25321.     i__4 = n;
  25322.     for (i = 1; i <= i__4; ++i) {
  25323. /*<       G5( I)= G3( I) >*/
  25324.     i__2 = i - 1;
  25325.     i__3 = i - 1;
  25326.     g5[i__2].r = g3[i__3].r, g5[i__2].i = g3[i__3].i;
  25327. /*<    16 G3( I)= G2( I) >*/
  25328. /* L16: */
  25329.     i__2 = i - 1;
  25330.     i__3 = i - 1;
  25331.     g3[i__2].r = g2[i__3].r, g3[i__2].i = g2[i__3].i;
  25332.     }
  25333. /*<       GOTO 5 >*/
  25334.     goto L5;
  25335. /*<    17 CONTINUE >*/
  25336. L17:
  25337.  
  25338. /*<       RETURN >*/
  25339.     return 0;
  25340. /*<    18 FORMAT(' ERROR - B LESS THAN A IN ROM2') >*/
  25341. /*<    19 FORMAT(' ROM2 -- STEP SIZE LIMITED AT Z =',1P,E12.5) >*/
  25342. /*<       END >*/
  25343. } /* rom2_ */
  25344.  
  25345. /* *** */
  25346. /*     DOUBLE PRECISION 6/4/85 */
  25347.  
  25348. /*<       SUBROUTINE SBF( I, IS, AA, BB, CC) >*/
  25349. /* Subroutine */ int sbf_(i, is, aa, bb, cc)
  25350. integer *i, *is;
  25351. doublereal *aa, *bb, *cc;
  25352. {
  25353.     /* Initialized data */
  25354.  
  25355.     static doublereal pi = 3.141592654;
  25356.     static integer jmax = 30;
  25357.  
  25358.     /* Format strings */
  25359.     static char fmt_25[] = "(\002 SBF - SEGMENT CONNECTION ERROR FOR SEGMEN\
  25360. T\002,i5)";
  25361.  
  25362.     /* System generated locals */
  25363.     doublereal d__1;
  25364.  
  25365.     /* Builtin functions */
  25366.     double sin(), cos(), log();
  25367.     integer s_wsfe(), do_fio(), e_wsfe();
  25368.     /* Subroutine */ int s_stop();
  25369.  
  25370.     /* Local variables */
  25371.     static integer iend, jend, june, jcox, jsno, njun1, njun2;
  25372.     static doublereal d, cd, aj, ap, sd, pp, pm, qp, qm, cdh, sdh, omc, sig, 
  25373.         xxi;
  25374.  
  25375.     /* Fortran I/O blocks */
  25376.     static cilist io___1987 = { 0, 6, 0, fmt_25, 0 };
  25377.  
  25378.  
  25379. /* *** */
  25380. /*     COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS. */
  25381. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  25382. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  25383. /*<    >*/
  25384. /*<       DATA   PI/3.141592654D+0/, JMAX/30/ >*/
  25385. /*<       AA=0. >*/
  25386.     *aa = 0.;
  25387. /*<       BB=0. >*/
  25388.     *bb = 0.;
  25389. /*<       CC=0. >*/
  25390.     *cc = 0.;
  25391. /*<       JUNE=0 >*/
  25392.     june = 0;
  25393. /*<       JSNO=0 >*/
  25394.     jsno = 0;
  25395. /*<       PP=0. >*/
  25396.     pp = 0.;
  25397. /*<       JCOX= ICON1( I) >*/
  25398.     jcox = data_1.icon1[*i - 1];
  25399. /*<       IF( JCOX.GT.10000) JCOX= I >*/
  25400.     if (jcox > 10000) {
  25401.     jcox = *i;
  25402.     }
  25403. /*<       JEND=-1 >*/
  25404.     jend = -1;
  25405. /*<       IEND=-1 >*/
  25406.     iend = -1;
  25407. /*<       SIG=-1. >*/
  25408.     sig = -1.;
  25409. /*<       IF( JCOX) 1,11,2 >*/
  25410.     if (jcox < 0) {
  25411.     goto L1;
  25412.     } else if (jcox == 0) {
  25413.     goto L11;
  25414.     } else {
  25415.     goto L2;
  25416.     }
  25417. /*<     1 JCOX=- JCOX >*/
  25418. L1:
  25419.     jcox = -jcox;
  25420. /*<       GOTO 3 >*/
  25421.     goto L3;
  25422. /*<     2 SIG=- SIG >*/
  25423. L2:
  25424.     sig = -sig;
  25425. /*<       JEND=- JEND >*/
  25426.     jend = -jend;
  25427. /*<     3 JSNO= JSNO+1 >*/
  25428. L3:
  25429.     ++jsno;
  25430. /*<       IF( JSNO.GE. JMAX) GOTO 24 >*/
  25431.     if (jsno >= jmax) {
  25432.     goto L24;
  25433.     }
  25434. /*<       D= PI* SI( JCOX) >*/
  25435.     d = pi * data_1.si[jcox - 1];
  25436. /*<       SDH= SIN( D) >*/
  25437.     sdh = sin(d);
  25438. /*<       CDH= COS( D) >*/
  25439.     cdh = cos(d);
  25440. /*<       SD=2.* SDH* CDH >*/
  25441.     d__1 = sdh * 2.;
  25442.     sd = d__1 * cdh;
  25443. /*<       IF( D.GT.0.015) GOTO 4 >*/
  25444.     if (d > .015) {
  25445.     goto L4;
  25446.     }
  25447. /*<       OMC=4.* D* D >*/
  25448.     d__1 = d * 4.;
  25449.     omc = d__1 * d;
  25450. /*<       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
  25451.     omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
  25452. /*<       GOTO 5 >*/
  25453.     goto L5;
  25454. /*<     4 OMC=1.- CDH* CDH+ SDH* SDH >*/
  25455. L4:
  25456.     omc = 1. - cdh * cdh + sdh * sdh;
  25457. /*<     5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0) >*/
  25458. L5:
  25459.     aj = 1. / (log(1. / (pi * data_1.bi[jcox - 1])) - .577215664);
  25460. /*<       PP= PP- OMC/ SD* AJ >*/
  25461.     pp -= omc / sd * aj;
  25462. /*<       IF( JCOX.NE. IS) GOTO 6 >*/
  25463.     if (jcox != *is) {
  25464.     goto L6;
  25465.     }
  25466. /*<       AA= AJ/ SD* SIG >*/
  25467.     *aa = aj / sd * sig;
  25468. /*<       BB= AJ/(2.* CDH) >*/
  25469.     *bb = aj / (cdh * 2.);
  25470. /*<       CC=- AJ/(2.* SDH)* SIG >*/
  25471.     *cc = -aj / (sdh * 2.) * sig;
  25472. /*<       JUNE= IEND >*/
  25473.     june = iend;
  25474. /*<     6 IF( JCOX.EQ. I) GOTO 9 >*/
  25475. L6:
  25476.     if (jcox == *i) {
  25477.     goto L9;
  25478.     }
  25479. /*<       IF( JEND.EQ.1) GOTO 7 >*/
  25480.     if (jend == 1) {
  25481.     goto L7;
  25482.     }
  25483. /*<       JCOX= ICON1( JCOX) >*/
  25484.     jcox = data_1.icon1[jcox - 1];
  25485. /*<       GOTO 8 >*/
  25486.     goto L8;
  25487. /*<     7 JCOX= ICON2( JCOX) >*/
  25488. L7:
  25489.     jcox = data_1.icon2[jcox - 1];
  25490. /*<     8 IF( IABS( JCOX).EQ. I) GOTO 10 >*/
  25491. L8:
  25492.     if (abs(jcox) == *i) {
  25493.     goto L10;
  25494.     }
  25495. /*<       IF( JCOX) 1,24,2 >*/
  25496.     if (jcox < 0) {
  25497.     goto L1;
  25498.     } else if (jcox == 0) {
  25499.     goto L24;
  25500.     } else {
  25501.     goto L2;
  25502.     }
  25503. /*<     9 IF( JCOX.EQ. IS) BB=- BB >*/
  25504. L9:
  25505.     if (jcox == *is) {
  25506.     *bb = -(*bb);
  25507.     }
  25508. /*<    10 IF( IEND.EQ.1) GOTO 12 >*/
  25509. L10:
  25510.     if (iend == 1) {
  25511.     goto L12;
  25512.     }
  25513. /*<    11 PM=- PP >*/
  25514. L11:
  25515.     pm = -pp;
  25516. /*<       PP=0. >*/
  25517.     pp = 0.;
  25518. /*<       NJUN1= JSNO >*/
  25519.     njun1 = jsno;
  25520. /*<       JCOX= ICON2( I) >*/
  25521.     jcox = data_1.icon2[*i - 1];
  25522. /*<       IF( JCOX.GT.10000) JCOX= I >*/
  25523.     if (jcox > 10000) {
  25524.     jcox = *i;
  25525.     }
  25526. /*<       JEND=1 >*/
  25527.     jend = 1;
  25528. /*<       IEND=1 >*/
  25529.     iend = 1;
  25530. /*<       SIG=-1. >*/
  25531.     sig = -1.;
  25532. /*<       IF( JCOX) 1,12,2 >*/
  25533.     if (jcox < 0) {
  25534.     goto L1;
  25535.     } else if (jcox == 0) {
  25536.     goto L12;
  25537.     } else {
  25538.     goto L2;
  25539.     }
  25540. /*<    12 NJUN2= JSNO- NJUN1 >*/
  25541. L12:
  25542.     njun2 = jsno - njun1;
  25543. /*<       D= PI* SI( I) >*/
  25544.     d = pi * data_1.si[*i - 1];
  25545. /*<       SDH= SIN( D) >*/
  25546.     sdh = sin(d);
  25547. /*<       CDH= COS( D) >*/
  25548.     cdh = cos(d);
  25549. /*<       SD=2.* SDH* CDH >*/
  25550.     d__1 = sdh * 2.;
  25551.     sd = d__1 * cdh;
  25552. /*<       CD= CDH* CDH- SDH* SDH >*/
  25553.     cd = cdh * cdh - sdh * sdh;
  25554. /*<       IF( D.GT.0.015) GOTO 13 >*/
  25555.     if (d > .015) {
  25556.     goto L13;
  25557.     }
  25558. /*<       OMC=4.* D* D >*/
  25559.     d__1 = d * 4.;
  25560.     omc = d__1 * d;
  25561. /*<       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
  25562.     omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
  25563. /*<       GOTO 14 >*/
  25564.     goto L14;
  25565. /*<    13 OMC=1.- CD >*/
  25566. L13:
  25567.     omc = 1. - cd;
  25568. /*<    14 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0) >*/
  25569. L14:
  25570.     ap = 1. / (log(1. / (pi * data_1.bi[*i - 1])) - .577215664);
  25571. /*<       AJ= AP >*/
  25572.     aj = ap;
  25573. /*<       IF( NJUN1.EQ.0) GOTO 19 >*/
  25574.     if (njun1 == 0) {
  25575.     goto L19;
  25576.     }
  25577. /*<       IF( NJUN2.EQ.0) GOTO 21 >*/
  25578.     if (njun2 == 0) {
  25579.     goto L21;
  25580.     }
  25581. /*<       QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ) >*/
  25582.     qp = sd * (pm * pp + aj * ap) + cd * (pm * ap - pp * aj);
  25583. /*<       QM=( AP* OMC- PP* SD)/ QP >*/
  25584.     qm = (ap * omc - pp * sd) / qp;
  25585. /*<       QP=-( AJ* OMC+ PM* SD)/ QP >*/
  25586.     qp = -(aj * omc + pm * sd) / qp;
  25587. /*<       IF( JUNE) 15,18,16 >*/
  25588.     if (june < 0) {
  25589.     goto L15;
  25590.     } else if (june == 0) {
  25591.     goto L18;
  25592.     } else {
  25593.     goto L16;
  25594.     }
  25595. /*<    15 AA= AA* QM >*/
  25596. L15:
  25597.     *aa *= qm;
  25598. /*<       BB= BB* QM >*/
  25599.     *bb *= qm;
  25600. /*<       CC= CC* QM >*/
  25601.     *cc *= qm;
  25602. /*<       GOTO 17 >*/
  25603.     goto L17;
  25604. /*<    16 AA=- AA* QP >*/
  25605. L16:
  25606.     *aa = -(*aa) * qp;
  25607. /*<       BB= BB* QP >*/
  25608.     *bb *= qp;
  25609. /*<       CC=- CC* QP >*/
  25610.     *cc = -(*cc) * qp;
  25611. /*<    17 IF( I.NE. IS) RETURN >*/
  25612. L17:
  25613.     if (*i != *is) {
  25614.     return 0;
  25615.     }
  25616. /*<    18 AA= AA-1. >*/
  25617. L18:
  25618.     *aa += -1.;
  25619. /*<       BB= BB+( AJ* QM+ AP* QP)* SDH/ SD >*/
  25620.     *bb += (aj * qm + ap * qp) * sdh / sd;
  25621. /*<       CC= CC+( AJ* QM- AP* QP)* CDH/ SD >*/
  25622.     *cc += (aj * qm - ap * qp) * cdh / sd;
  25623. /*<       RETURN >*/
  25624.     return 0;
  25625. /*<    19 IF( NJUN2.EQ.0) GOTO 23 >*/
  25626. L19:
  25627.     if (njun2 == 0) {
  25628.     goto L23;
  25629.     }
  25630. /*<       QP= PI* BI( I) >*/
  25631.     qp = pi * data_1.bi[*i - 1];
  25632. /*<       XXI= QP* QP >*/
  25633.     xxi = qp * qp;
  25634. /*<       XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
  25635.     xxi = qp * (1. - xxi * .5) / (1. - xxi);
  25636. /*<       QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP)) >*/
  25637.     qp = -(omc + xxi * sd) / (sd * (ap + xxi * pp) + cd * (xxi * ap - pp));
  25638. /*<       IF( JUNE.NE.1) GOTO 20 >*/
  25639.     if (june != 1) {
  25640.     goto L20;
  25641.     }
  25642. /*<       AA=- AA* QP >*/
  25643.     *aa = -(*aa) * qp;
  25644. /*<       BB= BB* QP >*/
  25645.     *bb *= qp;
  25646. /*<       CC=- CC* QP >*/
  25647.     *cc = -(*cc) * qp;
  25648. /*<       IF( I.NE. IS) RETURN >*/
  25649.     if (*i != *is) {
  25650.     return 0;
  25651.     }
  25652. /*<    20 AA= AA-1. >*/
  25653. L20:
  25654.     *aa += -1.;
  25655. /*<       D= CD- XXI* SD >*/
  25656.     d = cd - xxi * sd;
  25657. /*<       BB= BB+( SDH+ AP* QP*( CDH- XXI* SDH))/ D >*/
  25658.     d__1 = ap * qp;
  25659.     *bb += (sdh + d__1 * (cdh - xxi * sdh)) / d;
  25660. /*<       CC= CC+( CDH+ AP* QP*( SDH+ XXI* CDH))/ D >*/
  25661.     d__1 = ap * qp;
  25662.     *cc += (cdh + d__1 * (sdh + xxi * cdh)) / d;
  25663. /*<       RETURN >*/
  25664.     return 0;
  25665. /*<    21 QM= PI* BI( I) >*/
  25666. L21:
  25667.     qm = pi * data_1.bi[*i - 1];
  25668. /*<       XXI= QM* QM >*/
  25669.     xxi = qm * qm;
  25670. /*<       XXI= QM*(1.-.5* XXI)/(1.- XXI) >*/
  25671.     xxi = qm * (1. - xxi * .5) / (1. - xxi);
  25672. /*<       QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ)) >*/
  25673.     qm = (omc + xxi * sd) / (sd * (aj - xxi * pm) + cd * (pm + xxi * aj));
  25674. /*<       IF( JUNE.NE.-1) GOTO 22 >*/
  25675.     if (june != -1) {
  25676.     goto L22;
  25677.     }
  25678. /*<       AA= AA* QM >*/
  25679.     *aa *= qm;
  25680. /*<       BB= BB* QM >*/
  25681.     *bb *= qm;
  25682. /*<       CC= CC* QM >*/
  25683.     *cc *= qm;
  25684. /*<       IF( I.NE. IS) RETURN >*/
  25685.     if (*i != *is) {
  25686.     return 0;
  25687.     }
  25688. /*<    22 AA= AA-1. >*/
  25689. L22:
  25690.     *aa += -1.;
  25691. /*<       D= CD- XXI* SD >*/
  25692.     d = cd - xxi * sd;
  25693. /*<       BB= BB+( AJ* QM*( CDH- XXI* SDH)- SDH)/ D >*/
  25694.     d__1 = aj * qm;
  25695.     *bb += (d__1 * (cdh - xxi * sdh) - sdh) / d;
  25696. /*<       CC= CC+( CDH- AJ* QM*( SDH+ XXI* CDH))/ D >*/
  25697.     d__1 = aj * qm;
  25698.     *cc += (cdh - d__1 * (sdh + xxi * cdh)) / d;
  25699. /*<       RETURN >*/
  25700.     return 0;
  25701. /*<    23 AA=-1. >*/
  25702. L23:
  25703.     *aa = -1.;
  25704. /*<       QP= PI* BI( I) >*/
  25705.     qp = pi * data_1.bi[*i - 1];
  25706. /*<       XXI= QP* QP >*/
  25707.     xxi = qp * qp;
  25708. /*<       XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
  25709.     xxi = qp * (1. - xxi * .5) / (1. - xxi);
  25710. /*<       CC=1./( CDH- XXI* SDH) >*/
  25711.     *cc = 1. / (cdh - xxi * sdh);
  25712. /*<       RETURN >*/
  25713.     return 0;
  25714. /*<    24 WRITE( 6,25)  I >*/
  25715. L24:
  25716.     s_wsfe(&io___1987);
  25717.     do_fio(&c__1, (char *)&(*i), (ftnlen)sizeof(integer));
  25718.     e_wsfe();
  25719.  
  25720. /*<       STOP >*/
  25721.     s_stop("", 0L);
  25722. /*<    25 FORMAT(' SBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5) >*/
  25723. /*<       END >*/
  25724. } /* sbf_ */
  25725.  
  25726. /* *** */
  25727. /*     DOUBLE PRECISION 6/4/85 */
  25728.  
  25729. /*<       SUBROUTINE SFLDS( T, E) >*/
  25730. /* Subroutine */ int sflds_(t, e)
  25731. doublereal *t;
  25732. doublecomplex *e;
  25733. {
  25734.     /* Initialized data */
  25735.  
  25736.     static doublereal pi = 3.141592654;
  25737.     static doublereal tp = 6.283185308;
  25738.     static doublereal pot = 1.570796327;
  25739.  
  25740.     /* System generated locals */
  25741.     doublereal d__1, d__2;
  25742.     doublecomplex z__1, z__2, z__3, z__4;
  25743.  
  25744.     /* Builtin functions */
  25745.     double sqrt(), cos(), sin(), atan();
  25746.  
  25747.     /* Local variables */
  25748.     static doublereal sfac, thet, zphs;
  25749.     extern /* Subroutine */ int gwave_(), intrp_();
  25750.     static doublecomplex er, et;
  25751.     static doublereal rk, xt, yt, zt, r2s, cph;
  25752.     static doublecomplex eph, erh, hrh, ezh;
  25753.     static doublereal rho, sph;
  25754.     static doublecomplex erv;
  25755.     static doublereal rhs;
  25756.     static doublecomplex hrv, ezv;
  25757.     static doublereal rhx;
  25758.     static doublecomplex hzv;
  25759.     static doublereal rhy, phx, phy;
  25760.  
  25761. /* *** */
  25762.  
  25763. /*     SFLDX RETURNS THE FIELD DUE TO GROUND FOR A CURRENT ELEMENT ON */
  25764. /*     THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER. */
  25765.  
  25766. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  25767. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  25768. /*<    >*/
  25769. /*<    >*/
  25770. /*<       COMMON  /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR >*/
  25771. /*<       COMMON  /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
  25772. /*<    >*/
  25773. /*<       DIMENSION  E(9) >*/
  25774. /*<    >*/
  25775.     /* Parameter adjustments */
  25776.     --e;
  25777.  
  25778.     /* Function Body */
  25779. /*<       XT= XJ+ T* CABJ >*/
  25780.     xt = dataj_1.xj + *t * dataj_1.cabj;
  25781. /*<       YT= YJ+ T* SABJ >*/
  25782.     yt = dataj_1.yj + *t * dataj_1.sabj;
  25783. /*<       ZT= ZJ+ T* SALPJ >*/
  25784.     zt = dataj_1.zj + *t * dataj_1.salpj;
  25785. /*<       RHX= XO- XT >*/
  25786.     rhx = incom_1.xo - xt;
  25787. /*<       RHY= YO- YT >*/
  25788.     rhy = incom_1.yo - yt;
  25789. /*<       RHS= RHX* RHX+ RHY* RHY >*/
  25790.     rhs = rhx * rhx + rhy * rhy;
  25791. /*<       RHO= SQRT( RHS) >*/
  25792.     rho = sqrt(rhs);
  25793. /*<       IF( RHO.GT.0.) GOTO 1 >*/
  25794.     if (rho > 0.) {
  25795.     goto L1;
  25796.     }
  25797. /*<       RHX=1. >*/
  25798.     rhx = 1.;
  25799. /*<       RHY=0. >*/
  25800.     rhy = 0.;
  25801. /*<       PHX=0. >*/
  25802.     phx = 0.;
  25803. /*<       PHY=1. >*/
  25804.     phy = 1.;
  25805. /*<       GOTO 2 >*/
  25806.     goto L2;
  25807. /*<     1 RHX= RHX/ RHO >*/
  25808. L1:
  25809.     rhx /= rho;
  25810. /*<       RHY= RHY/ RHO >*/
  25811.     rhy /= rho;
  25812. /*<       PHX=- RHY >*/
  25813.     phx = -rhy;
  25814. /*<       PHY= RHX >*/
  25815.     phy = rhx;
  25816. /*<     2 CPH= RHX* XSN+ RHY* YSN >*/
  25817. L2:
  25818.     cph = rhx * incom_1.xsn + rhy * incom_1.ysn;
  25819. /*<       SPH= RHY* XSN- RHX* YSN >*/
  25820.     sph = rhy * incom_1.xsn - rhx * incom_1.ysn;
  25821. /*<       IF( ABS( CPH).LT.1.D-10) CPH=0. >*/
  25822.     if (abs(cph) < 1e-10) {
  25823.     cph = 0.;
  25824.     }
  25825. /*<       IF( ABS( SPH).LT.1.D-10) SPH=0. >*/
  25826.     if (abs(sph) < 1e-10) {
  25827.     sph = 0.;
  25828.     }
  25829. /*<       ZPH= ZO+ ZT >*/
  25830.     gwav_1.zph = incom_1.zo + zt;
  25831. /*<       ZPHS= ZPH* ZPH >*/
  25832.     zphs = gwav_1.zph * gwav_1.zph;
  25833. /*<       R2S= RHS+ ZPHS >*/
  25834.     r2s = rhs + zphs;
  25835. /*<       R2= SQRT( R2S) >*/
  25836.     gwav_1.r2 = sqrt(r2s);
  25837. /*<       RK= R2* TP >*/
  25838.     rk = gwav_1.r2 * tp;
  25839. /*<       XX2= CMPLX( COS( RK),- SIN( RK)) >*/
  25840.     d__1 = cos(rk);
  25841.     d__2 = -sin(rk);
  25842.     z__1.r = d__1, z__1.i = d__2;
  25843.     gwav_1.xx2.r = z__1.r, gwav_1.xx2.i = z__1.i;
  25844.  
  25845. /*     USE NORTON APPROXIMATION FOR FIELD DUE TO GROUND.  CURRENT IS */
  25846. /*     LUMPED AT SEGMENT CENTER WITH CURRENT MOMENT FOR CONSTANT, SINE, */
  25847.  
  25848. /*     OR COSINE DISTRIBUTION. */
  25849.  
  25850. /*<       IF( ISNOR.EQ.1) GOTO 3 >*/
  25851.     if (incom_1.isnor == 1) {
  25852.     goto L3;
  25853.     }
  25854. /*<       ZMH=1. >*/
  25855.     gwav_1.zmh = 1.;
  25856. /*<       R1=1. >*/
  25857.     gwav_1.r1 = 1.;
  25858. /*<       XX1=0. >*/
  25859.     gwav_1.xx1.r = 0., gwav_1.xx1.i = 0.;
  25860. /*<       CALL GWAVE( ERV, EZV, ERH, EZH, EPH) >*/
  25861.     gwave_(&erv, &ezv, &erh, &ezh, &eph);
  25862. /*<       ET=-(0.,4.77134)* FRATI* XX2/( R2S* R2) >*/
  25863.     z__3.r = gnd_1.frati.r * 0. - gnd_1.frati.i * -4.77134, z__3.i = 
  25864.         gnd_1.frati.r * -4.77134 + gnd_1.frati.i * 0.;
  25865.     z__2.r = z__3.r * gwav_1.xx2.r - z__3.i * gwav_1.xx2.i, z__2.i = z__3.r * 
  25866.         gwav_1.xx2.i + z__3.i * gwav_1.xx2.r;
  25867.     d__1 = r2s * gwav_1.r2;
  25868.     z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
  25869.     et.r = z__1.r, et.i = z__1.i;
  25870. /*<       ER=2.* ET* CMPLX(1.0, RK) >*/
  25871.     z__2.r = et.r * 2., z__2.i = et.i * 2.;
  25872.     z__3.r = 1., z__3.i = rk;
  25873.     z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + 
  25874.         z__2.i * z__3.r;
  25875.     er.r = z__1.r, er.i = z__1.i;
  25876. /*<       ET= ET* CMPLX(1.0 - RK* RK, RK) >*/
  25877.     d__1 = 1. - rk * rk;
  25878.     z__2.r = d__1, z__2.i = rk;
  25879.     z__1.r = et.r * z__2.r - et.i * z__2.i, z__1.i = et.r * z__2.i + et.i * 
  25880.         z__2.r;
  25881.     et.r = z__1.r, et.i = z__1.i;
  25882. /*<       HRV=( ER+ ET)* RHO* ZPH/ R2S >*/
  25883.     z__4.r = er.r + et.r, z__4.i = er.i + et.i;
  25884.     z__3.r = rho * z__4.r, z__3.i = rho * z__4.i;
  25885.     z__2.r = gwav_1.zph * z__3.r, z__2.i = gwav_1.zph * z__3.i;
  25886.     z__1.r = z__2.r / r2s, z__1.i = z__2.i / r2s;
  25887.     hrv.r = z__1.r, hrv.i = z__1.i;
  25888. /*<       HZV=( ZPHS* ER- RHS* ET)/ R2S >*/
  25889.     z__3.r = zphs * er.r, z__3.i = zphs * er.i;
  25890.     z__4.r = rhs * et.r, z__4.i = rhs * et.i;
  25891.     z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
  25892.     z__1.r = z__2.r / r2s, z__1.i = z__2.i / r2s;
  25893.     hzv.r = z__1.r, hzv.i = z__1.i;
  25894. /*<       HRH=( RHS* ER- ZPHS* ET)/ R2S >*/
  25895.     z__3.r = rhs * er.r, z__3.i = rhs * er.i;
  25896.     z__4.r = zphs * et.r, z__4.i = zphs * et.i;
  25897.     z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
  25898.     z__1.r = z__2.r / r2s, z__1.i = z__2.i / r2s;
  25899.     hrh.r = z__1.r, hrh.i = z__1.i;
  25900. /*<       ERV= ERV- HRV >*/
  25901.     z__1.r = erv.r - hrv.r, z__1.i = erv.i - hrv.i;
  25902.     erv.r = z__1.r, erv.i = z__1.i;
  25903. /*<       EZV= EZV- HZV >*/
  25904.     z__1.r = ezv.r - hzv.r, z__1.i = ezv.i - hzv.i;
  25905.     ezv.r = z__1.r, ezv.i = z__1.i;
  25906. /*<       ERH= ERH+ HRH >*/
  25907.     z__1.r = erh.r + hrh.r, z__1.i = erh.i + hrh.i;
  25908.     erh.r = z__1.r, erh.i = z__1.i;
  25909. /*<       EZH= EZH+ HRV >*/
  25910.     z__1.r = ezh.r + hrv.r, z__1.i = ezh.i + hrv.i;
  25911.     ezh.r = z__1.r, ezh.i = z__1.i;
  25912. /*<       EPH= EPH+ ET >*/
  25913.     z__1.r = eph.r + et.r, z__1.i = eph.i + et.i;
  25914.     eph.r = z__1.r, eph.i = z__1.i;
  25915. /*<       ERV= ERV* SALPJ >*/
  25916.     z__1.r = dataj_1.salpj * erv.r, z__1.i = dataj_1.salpj * erv.i;
  25917.     erv.r = z__1.r, erv.i = z__1.i;
  25918. /*<       EZV= EZV* SALPJ >*/
  25919.     z__1.r = dataj_1.salpj * ezv.r, z__1.i = dataj_1.salpj * ezv.i;
  25920.     ezv.r = z__1.r, ezv.i = z__1.i;
  25921. /*<       ERH= ERH* SN* CPH >*/
  25922.     z__2.r = incom_1.sn * erh.r, z__2.i = incom_1.sn * erh.i;
  25923.     z__1.r = cph * z__2.r, z__1.i = cph * z__2.i;
  25924.     erh.r = z__1.r, erh.i = z__1.i;
  25925. /*<       EZH= EZH* SN* CPH >*/
  25926.     z__2.r = incom_1.sn * ezh.r, z__2.i = incom_1.sn * ezh.i;
  25927.     z__1.r = cph * z__2.r, z__1.i = cph * z__2.i;
  25928.     ezh.r = z__1.r, ezh.i = z__1.i;
  25929. /*<       EPH= EPH* SN* SPH >*/
  25930.     z__2.r = incom_1.sn * eph.r, z__2.i = incom_1.sn * eph.i;
  25931.     z__1.r = sph * z__2.r, z__1.i = sph * z__2.i;
  25932.     eph.r = z__1.r, eph.i = z__1.i;
  25933. /*<       ERH= ERV+ ERH >*/
  25934.     z__1.r = erv.r + erh.r, z__1.i = erv.i + erh.i;
  25935.     erh.r = z__1.r, erh.i = z__1.i;
  25936. /*<       E(1)=( ERH* RHX+ EPH* PHX)* S >*/
  25937.     z__3.r = rhx * erh.r, z__3.i = rhx * erh.i;
  25938.     z__4.r = phx * eph.r, z__4.i = phx * eph.i;
  25939.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  25940.     z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
  25941.     e[1].r = z__1.r, e[1].i = z__1.i;
  25942. /*<       E(2)=( ERH* RHY+ EPH* PHY)* S >*/
  25943.     z__3.r = rhy * erh.r, z__3.i = rhy * erh.i;
  25944.     z__4.r = phy * eph.r, z__4.i = phy * eph.i;
  25945.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  25946.     z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
  25947.     e[2].r = z__1.r, e[2].i = z__1.i;
  25948. /*<       E(3)=( EZV+ EZH)* S >*/
  25949.     z__2.r = ezv.r + ezh.r, z__2.i = ezv.i + ezh.i;
  25950.     z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
  25951.     e[3].r = z__1.r, e[3].i = z__1.i;
  25952. /*<       E(4)=0. >*/
  25953.     e[4].r = 0., e[4].i = 0.;
  25954. /*<       E(5)=0. >*/
  25955.     e[5].r = 0., e[5].i = 0.;
  25956. /*<       E(6)=0. >*/
  25957.     e[6].r = 0., e[6].i = 0.;
  25958. /*<       SFAC= PI* S >*/
  25959.     sfac = pi * dataj_1.s;
  25960. /*<       SFAC= SIN( SFAC)/ SFAC >*/
  25961.     sfac = sin(sfac) / sfac;
  25962. /*<       E(7)= E(1)* SFAC >*/
  25963.     z__1.r = sfac * e[1].r, z__1.i = sfac * e[1].i;
  25964.     e[7].r = z__1.r, e[7].i = z__1.i;
  25965. /*<       E(8)= E(2)* SFAC >*/
  25966.     z__1.r = sfac * e[2].r, z__1.i = sfac * e[2].i;
  25967.     e[8].r = z__1.r, e[8].i = z__1.i;
  25968. /*<       E(9)= E(3)* SFAC >*/
  25969.     z__1.r = sfac * e[3].r, z__1.i = sfac * e[3].i;
  25970.     e[9].r = z__1.r, e[9].i = z__1.i;
  25971.  
  25972. /*     INTERPOLATE IN SOMMERFELD FIELD TABLES */
  25973.  
  25974. /*<       RETURN >*/
  25975.     return 0;
  25976. /*<     3 IF( RHO.LT.1.D-12) GOTO 4 >*/
  25977. L3:
  25978.     if (rho < 1e-12) {
  25979.     goto L4;
  25980.     }
  25981. /*<       THET= ATAN( ZPH/ RHO) >*/
  25982.     thet = atan(gwav_1.zph / rho);
  25983. /*<       GOTO 5 >*/
  25984.     goto L5;
  25985. /*<     4 THET= POT >*/
  25986. L4:
  25987.     thet = pot;
  25988. /*     COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z */
  25989. /*     COMPONENTS.  MULTIPLY BY EXP(-JKR)/R. */
  25990. /*<     5 CALL INTRP( R2, THET, ERV, EZV, ERH, EPH) >*/
  25991. L5:
  25992.     intrp_(&gwav_1.r2, &thet, &erv, &ezv, &erh, &eph);
  25993. /*<       XX2= XX2/ R2 >*/
  25994.     z__1.r = gwav_1.xx2.r / gwav_1.r2, z__1.i = gwav_1.xx2.i / gwav_1.r2;
  25995.     gwav_1.xx2.r = z__1.r, gwav_1.xx2.i = z__1.i;
  25996. /*<       SFAC= SN* CPH >*/
  25997.     sfac = incom_1.sn * cph;
  25998. /*<       ERH= XX2*( SALPJ* ERV+ SFAC* ERH) >*/
  25999.     z__3.r = dataj_1.salpj * erv.r, z__3.i = dataj_1.salpj * erv.i;
  26000.     z__4.r = sfac * erh.r, z__4.i = sfac * erh.i;
  26001.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  26002.     z__1.r = gwav_1.xx2.r * z__2.r - gwav_1.xx2.i * z__2.i, z__1.i = 
  26003.         gwav_1.xx2.r * z__2.i + gwav_1.xx2.i * z__2.r;
  26004.     erh.r = z__1.r, erh.i = z__1.i;
  26005. /*<       EZH= XX2*( SALPJ* EZV- SFAC* ERV) >*/
  26006.     z__3.r = dataj_1.salpj * ezv.r, z__3.i = dataj_1.salpj * ezv.i;
  26007.     z__4.r = sfac * erv.r, z__4.i = sfac * erv.i;
  26008.     z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
  26009.     z__1.r = gwav_1.xx2.r * z__2.r - gwav_1.xx2.i * z__2.i, z__1.i = 
  26010.         gwav_1.xx2.r * z__2.i + gwav_1.xx2.i * z__2.r;
  26011.     ezh.r = z__1.r, ezh.i = z__1.i;
  26012. /*     X,Y,Z FIELDS FOR CONSTANT CURRENT */
  26013. /*<       EPH= SN* SPH* XX2* EPH >*/
  26014.     d__1 = incom_1.sn * sph;
  26015.     z__2.r = d__1 * gwav_1.xx2.r, z__2.i = d__1 * gwav_1.xx2.i;
  26016.     z__1.r = z__2.r * eph.r - z__2.i * eph.i, z__1.i = z__2.r * eph.i + 
  26017.         z__2.i * eph.r;
  26018.     eph.r = z__1.r, eph.i = z__1.i;
  26019. /*<       E(1)= ERH* RHX+ EPH* PHX >*/
  26020.     z__2.r = rhx * erh.r, z__2.i = rhx * erh.i;
  26021.     z__3.r = phx * eph.r, z__3.i = phx * eph.i;
  26022.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  26023.     e[1].r = z__1.r, e[1].i = z__1.i;
  26024. /*<       E(2)= ERH* RHY+ EPH* PHY >*/
  26025.     z__2.r = rhy * erh.r, z__2.i = rhy * erh.i;
  26026.     z__3.r = phy * eph.r, z__3.i = phy * eph.i;
  26027.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  26028.     e[2].r = z__1.r, e[2].i = z__1.i;
  26029. /*<       E(3)= EZH >*/
  26030.     e[3].r = ezh.r, e[3].i = ezh.i;
  26031. /*     X,Y,Z FIELDS FOR SINE CURRENT */
  26032. /*<       RK= TP* T >*/
  26033.     rk = tp * *t;
  26034. /*<       SFAC= SIN( RK) >*/
  26035.     sfac = sin(rk);
  26036. /*<       E(4)= E(1)* SFAC >*/
  26037.     z__1.r = sfac * e[1].r, z__1.i = sfac * e[1].i;
  26038.     e[4].r = z__1.r, e[4].i = z__1.i;
  26039. /*<       E(5)= E(2)* SFAC >*/
  26040.     z__1.r = sfac * e[2].r, z__1.i = sfac * e[2].i;
  26041.     e[5].r = z__1.r, e[5].i = z__1.i;
  26042. /*     X,Y,Z FIELDS FOR COSINE CURRENT */
  26043. /*<       E(6)= E(3)* SFAC >*/
  26044.     z__1.r = sfac * e[3].r, z__1.i = sfac * e[3].i;
  26045.     e[6].r = z__1.r, e[6].i = z__1.i;
  26046. /*<       SFAC= COS( RK) >*/
  26047.     sfac = cos(rk);
  26048. /*<       E(7)= E(1)* SFAC >*/
  26049.     z__1.r = sfac * e[1].r, z__1.i = sfac * e[1].i;
  26050.     e[7].r = z__1.r, e[7].i = z__1.i;
  26051. /*<       E(8)= E(2)* SFAC >*/
  26052.     z__1.r = sfac * e[2].r, z__1.i = sfac * e[2].i;
  26053.     e[8].r = z__1.r, e[8].i = z__1.i;
  26054. /*<       E(9)= E(3)* SFAC >*/
  26055.     z__1.r = sfac * e[3].r, z__1.i = sfac * e[3].i;
  26056.     e[9].r = z__1.r, e[9].i = z__1.i;
  26057. /*<       RETURN >*/
  26058.     return 0;
  26059. /*<       END >*/
  26060. } /* sflds_ */
  26061.  
  26062. /* *** */
  26063. /*     DOUBLE PRECISION 6/4/85 */
  26064.  
  26065. /*<    >*/
  26066. /* Subroutine */ int solgf_(a, b, c, d, xy, ip, np, n1, n, mp, m1, m, n1c, 
  26067.     n2c, n2cz)
  26068. doublecomplex *a, *b, *c, *d, *xy;
  26069. integer *ip, *np, *n1, *n, *mp, *m1, *m, *n1c, *n2c, *n2cz;
  26070. {
  26071.     /* System generated locals */
  26072.     integer b_dim1, b_offset, c_dim1, c_offset, d_dim1, d_offset, i__1, i__2, 
  26073.         i__3, i__4, i__5;
  26074.     doublecomplex z__1, z__2;
  26075.     alist al__1;
  26076.  
  26077.     /* Builtin functions */
  26078.     integer s_rsue(), do_uio(), e_rsue(), f_rew();
  26079.  
  26080.     /* Local variables */
  26081.     static integer neqs, i, j, icass;
  26082.     extern /* Subroutine */ int solve_();
  26083.     static integer n2, nlsys, npsys, ii, jj, ni, jp, nblsys;
  26084.     extern /* Subroutine */ int solves_(), ltsolv_();
  26085.     static integer ifl, npb, neq, npm;
  26086.     static doublecomplex sum;
  26087.  
  26088.     /* Fortran I/O blocks */
  26089.     static cilist io___2027 = { 0, 15, 0, 0, 0 };
  26090.     static cilist io___2030 = { 0, 11, 0, 0, 0 };
  26091.     static cilist io___2035 = { 0, 14, 0, 0, 0 };
  26092.  
  26093.  
  26094. /* *** */
  26095. /*     SOLVE FOR CURRENT IN N.G.F. PROCEDURE */
  26096. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  26097. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  26098. /*<       COMPLEX  A, B, C, D, SUM, XY, Y >*/
  26099. /*<       COMMON  /SCRATM/ Y( N2M) >*/
  26100. /*<    >*/
  26101. /*<    >*/
  26102. /*<       DIMENSION  A(1), B( N1C,1), C( N1C,1), D( N2CZ,1), IP(1), XY(1) >*/
  26103. /*<       IFL=14 >*/
  26104.     /* Parameter adjustments */
  26105.     --ip;
  26106.     --xy;
  26107.     d_dim1 = *n2cz;
  26108.     d_offset = d_dim1 + 1;
  26109.     d -= d_offset;
  26110.     c_dim1 = *n1c;
  26111.     c_offset = c_dim1 + 1;
  26112.     c -= c_offset;
  26113.     b_dim1 = *n1c;
  26114.     b_offset = b_dim1 + 1;
  26115.     b -= b_offset;
  26116.     --a;
  26117.  
  26118.     /* Function Body */
  26119.     ifl = 14;
  26120. /*<       IF( ICASX.GT.0) IFL=13 >*/
  26121.     if (matpar_1.icasx > 0) {
  26122.     ifl = 13;
  26123.     }
  26124. /*     NORMAL SOLUTION.  NOT N.G.F. */
  26125. /*<       IF( N2C.GT.0) GOTO 1 >*/
  26126.     if (*n2c > 0) {
  26127.     goto L1;
  26128.     }
  26129. /*<       CALL SOLVES( A, IP, XY, N1C,1, NP, N, MP, M,13, IFL) >*/
  26130.     solves_(&a[1], &ip[1], &xy[1], n1c, &c__1, np, n, mp, m, &c__13, &ifl);
  26131. /*<       GOTO 22 >*/
  26132.     goto L22;
  26133. /*     REORDER EXCITATION ARRAY */
  26134. /*<     1 IF( N1.EQ. N.OR. M1.EQ.0) GOTO 5 >*/
  26135. L1:
  26136.     if (*n1 == *n || *m1 == 0) {
  26137.     goto L5;
  26138.     }
  26139. /*<       N2= N1+1 >*/
  26140.     n2 = *n1 + 1;
  26141. /*<       JJ= N+1 >*/
  26142.     jj = *n + 1;
  26143. /*<       NPM= N+2* M1 >*/
  26144.     npm = *n + (*m1 << 1);
  26145. /*<       DO 2  I= N2, NPM >*/
  26146.     i__1 = npm;
  26147.     for (i = n2; i <= i__1; ++i) {
  26148. /*<     2 Y( I)= XY( I) >*/
  26149. /* L2: */
  26150.     i__2 = i - 1;
  26151.     i__3 = i;
  26152.     scratm_2.y[i__2].r = xy[i__3].r, scratm_2.y[i__2].i = xy[i__3].i;
  26153.     }
  26154. /*<       J= N1 >*/
  26155.     j = *n1;
  26156. /*<       DO 3  I= JJ, NPM >*/
  26157.     i__2 = npm;
  26158.     for (i = jj; i <= i__2; ++i) {
  26159. /*<       J= J+1 >*/
  26160.     ++j;
  26161. /*<     3 XY( J)= Y( I) >*/
  26162. /* L3: */
  26163.     i__3 = j;
  26164.     i__1 = i - 1;
  26165.     xy[i__3].r = scratm_2.y[i__1].r, xy[i__3].i = scratm_2.y[i__1].i;
  26166.     }
  26167. /*<       DO 4  I= N2, N >*/
  26168.     i__3 = *n;
  26169.     for (i = n2; i <= i__3; ++i) {
  26170. /*<       J= J+1 >*/
  26171.     ++j;
  26172. /*<     4 XY( J)= Y( I) >*/
  26173. /* L4: */
  26174.     i__1 = j;
  26175.     i__2 = i - 1;
  26176.     xy[i__1].r = scratm_2.y[i__2].r, xy[i__1].i = scratm_2.y[i__2].i;
  26177.     }
  26178. /*<     5 NEQS= NSCON+2* NPCON >*/
  26179. L5:
  26180.     neqs = segj_1.nscon + (segj_1.npcon << 1);
  26181. /*<       IF( NEQS.EQ.0) GOTO 7 >*/
  26182.     if (neqs == 0) {
  26183.     goto L7;
  26184.     }
  26185. /*<       NEQ= N1C+ N2C >*/
  26186.     neq = *n1c + *n2c;
  26187. /*     COMPUTE INV(A)E1 */
  26188. /*<       NEQS= NEQ- NEQS+1 >*/
  26189.     neqs = neq - neqs + 1;
  26190. /*<       DO 6  I= NEQS, NEQ >*/
  26191.     i__1 = neq;
  26192.     for (i = neqs; i <= i__1; ++i) {
  26193. /*<     6 XY( I)=(0.,0.) >*/
  26194. /* L6: */
  26195.     i__2 = i;
  26196.     xy[i__2].r = 0., xy[i__2].i = 0.;
  26197.     }
  26198. /*<     7 CALL SOLVES( A, IP, XY, N1C,1, NP, N1, MP, M1,13, IFL) >*/
  26199. L7:
  26200.     solves_(&a[1], &ip[1], &xy[1], n1c, &c__1, np, n1, mp, m1, &c__13, &ifl);
  26201. /*<       NI=0 >*/
  26202.     ni = 0;
  26203. /*     COMPUTE E2-C(INV(A)E1) */
  26204. /*<       NPB= NPBL >*/
  26205.     npb = matpar_1.npbl;
  26206. /*<       DO 10  JJ=1, NBBL >*/
  26207.     i__2 = matpar_1.nbbl;
  26208.     for (jj = 1; jj <= i__2; ++jj) {
  26209. /*<       IF( JJ.EQ. NBBL) NPB= NLBL >*/
  26210.     if (jj == matpar_1.nbbl) {
  26211.         npb = matpar_1.nlbl;
  26212.     }
  26213. /*<       IF( ICASX.GT.1) READ( 15) (( C( I, J), I=1, N1C), J=1, NPB) >*/
  26214.     if (matpar_1.icasx > 1) {
  26215.         s_rsue(&io___2027);
  26216.         i__1 = npb;
  26217.         for (j = 1; j <= i__1; ++j) {
  26218.         i__3 = *n1c;
  26219.         for (i = 1; i <= i__3; ++i) {
  26220.             do_uio(&c__2, (char *)&c[i + j * c_dim1], (ftnlen)sizeof(
  26221.                 doublereal));
  26222.         }
  26223.         }
  26224.         e_rsue();
  26225.     }
  26226. /*<       II= N1C+ NI >*/
  26227.     ii = *n1c + ni;
  26228. /*<       DO 9  I=1, NPB >*/
  26229.     i__3 = npb;
  26230.     for (i = 1; i <= i__3; ++i) {
  26231. /*<       SUM=(0.,0.) >*/
  26232.         sum.r = 0., sum.i = 0.;
  26233. /*<       DO 8  J=1, N1C >*/
  26234.         i__1 = *n1c;
  26235.         for (j = 1; j <= i__1; ++j) {
  26236. /*<     8 SUM= SUM+ C( J, I)* XY( J) >*/
  26237. /* L8: */
  26238.         i__4 = j + i * c_dim1;
  26239.         i__5 = j;
  26240.         z__2.r = c[i__4].r * xy[i__5].r - c[i__4].i * xy[i__5].i, 
  26241.             z__2.i = c[i__4].r * xy[i__5].i + c[i__4].i * xy[i__5]
  26242.             .r;
  26243.         z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  26244.         sum.r = z__1.r, sum.i = z__1.i;
  26245.         }
  26246. /*<       J= II+ I >*/
  26247.         j = ii + i;
  26248. /*<     9 XY( J)= XY( J)- SUM >*/
  26249. /* L9: */
  26250.         i__4 = j;
  26251.         i__5 = j;
  26252.         z__1.r = xy[i__5].r - sum.r, z__1.i = xy[i__5].i - sum.i;
  26253.         xy[i__4].r = z__1.r, xy[i__4].i = z__1.i;
  26254.     }
  26255. /*<    10 NI= NI+ NPBL >*/
  26256. /* L10: */
  26257.     ni += matpar_1.npbl;
  26258.     }
  26259. /*<       REWIND 15 >*/
  26260.     al__1.aerr = 0;
  26261.     al__1.aunit = 15;
  26262.     f_rew(&al__1);
  26263. /*     COMPUTE INV(D)(E2-C(INV(A)E1)) = I2 */
  26264. /*<       JJ= N1C+1 >*/
  26265.     jj = *n1c + 1;
  26266. /*<       IF( ICASX.GT.1) GOTO 11 >*/
  26267.     if (matpar_1.icasx > 1) {
  26268.     goto L11;
  26269.     }
  26270. /*<       CALL SOLVE( N2C, D, IP( JJ), XY( JJ), N2C) >*/
  26271.     solve_(n2c, &d[d_offset], &ip[jj], &xy[jj], n2c);
  26272. /*<       GOTO 13 >*/
  26273.     goto L13;
  26274. /*<    11 IF( ICASX.EQ.4) GOTO 12 >*/
  26275. L11:
  26276.     if (matpar_1.icasx == 4) {
  26277.     goto L12;
  26278.     }
  26279. /*<       NI= N2C* N2C >*/
  26280.     ni = *n2c * *n2c;
  26281. /*<       READ( 11) ( B( J,1), J=1, NI) >*/
  26282.     s_rsue(&io___2030);
  26283.     i__2 = ni;
  26284.     for (j = 1; j <= i__2; ++j) {
  26285.     do_uio(&c__2, (char *)&b[j + b_dim1], (ftnlen)sizeof(doublereal));
  26286.     }
  26287.     e_rsue();
  26288. /*<       REWIND 11 >*/
  26289.     al__1.aerr = 0;
  26290.     al__1.aunit = 11;
  26291.     f_rew(&al__1);
  26292. /*<       CALL SOLVE( N2C, B, IP( JJ), XY( JJ), N2C) >*/
  26293.     solve_(n2c, &b[b_offset], &ip[jj], &xy[jj], n2c);
  26294. /*<       GOTO 13 >*/
  26295.     goto L13;
  26296. /*<    12 NBLSYS= NBLSYM >*/
  26297. L12:
  26298.     nblsys = matpar_1.nblsym;
  26299. /*<       NPSYS= NPSYM >*/
  26300.     npsys = matpar_1.npsym;
  26301. /*<       NLSYS= NLSYM >*/
  26302.     nlsys = matpar_1.nlsym;
  26303. /*<       ICASS= ICASE >*/
  26304.     icass = matpar_1.icase;
  26305. /*<       NBLSYM= NBBL >*/
  26306.     matpar_1.nblsym = matpar_1.nbbl;
  26307. /*<       NPSYM= NPBL >*/
  26308.     matpar_1.npsym = matpar_1.npbl;
  26309. /*<       NLSYM= NLBL >*/
  26310.     matpar_1.nlsym = matpar_1.nlbl;
  26311. /*<       ICASE=3 >*/
  26312.     matpar_1.icase = 3;
  26313. /*<       REWIND 11 >*/
  26314.     al__1.aerr = 0;
  26315.     al__1.aunit = 11;
  26316.     f_rew(&al__1);
  26317. /*<       REWIND 16 >*/
  26318.     al__1.aerr = 0;
  26319.     al__1.aunit = 16;
  26320.     f_rew(&al__1);
  26321. /*<       CALL LTSOLV( B, N2C, IP( JJ), XY( JJ), N2C,1,11,16) >*/
  26322.     ltsolv_(&b[b_offset], n2c, &ip[jj], &xy[jj], n2c, &c__1, &c__11, &c__16);
  26323. /*<       REWIND 11 >*/
  26324.     al__1.aerr = 0;
  26325.     al__1.aunit = 11;
  26326.     f_rew(&al__1);
  26327. /*<       REWIND 16 >*/
  26328.     al__1.aerr = 0;
  26329.     al__1.aunit = 16;
  26330.     f_rew(&al__1);
  26331. /*<       NBLSYM= NBLSYS >*/
  26332.     matpar_1.nblsym = nblsys;
  26333. /*<       NPSYM= NPSYS >*/
  26334.     matpar_1.npsym = npsys;
  26335. /*<       NLSYM= NLSYS >*/
  26336.     matpar_1.nlsym = nlsys;
  26337. /*<       ICASE= ICASS >*/
  26338.     matpar_1.icase = icass;
  26339. /*<    13 NI=0 >*/
  26340. L13:
  26341.     ni = 0;
  26342. /*     COMPUTE INV(A)E1-(INV(A)B)I2 = I1 */
  26343. /*<       NPB= NPBL >*/
  26344.     npb = matpar_1.npbl;
  26345. /*<       DO 16  JJ=1, NBBL >*/
  26346.     i__2 = matpar_1.nbbl;
  26347.     for (jj = 1; jj <= i__2; ++jj) {
  26348. /*<       IF( JJ.EQ. NBBL) NPB= NLBL >*/
  26349.     if (jj == matpar_1.nbbl) {
  26350.         npb = matpar_1.nlbl;
  26351.     }
  26352. /*<       IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB) >*/
  26353.     if (matpar_1.icasx > 1) {
  26354.         s_rsue(&io___2035);
  26355.         i__4 = npb;
  26356.         for (j = 1; j <= i__4; ++j) {
  26357.         i__5 = *n1c;
  26358.         for (i = 1; i <= i__5; ++i) {
  26359.             do_uio(&c__2, (char *)&b[i + j * b_dim1], (ftnlen)sizeof(
  26360.                 doublereal));
  26361.         }
  26362.         }
  26363.         e_rsue();
  26364.     }
  26365. /*<       II= N1C+ NI >*/
  26366.     ii = *n1c + ni;
  26367. /*<       DO 15  I=1, N1C >*/
  26368.     i__5 = *n1c;
  26369.     for (i = 1; i <= i__5; ++i) {
  26370. /*<       SUM=(0.,0.) >*/
  26371.         sum.r = 0., sum.i = 0.;
  26372. /*<       DO 14  J=1, NPB >*/
  26373.         i__4 = npb;
  26374.         for (j = 1; j <= i__4; ++j) {
  26375. /*<       JP= II+ J >*/
  26376.         jp = ii + j;
  26377. /*<    14 SUM= SUM+ B( I, J)* XY( JP) >*/
  26378. /* L14: */
  26379.         i__3 = i + j * b_dim1;
  26380.         i__1 = jp;
  26381.         z__2.r = b[i__3].r * xy[i__1].r - b[i__3].i * xy[i__1].i, 
  26382.             z__2.i = b[i__3].r * xy[i__1].i + b[i__3].i * xy[i__1]
  26383.             .r;
  26384.         z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  26385.         sum.r = z__1.r, sum.i = z__1.i;
  26386.         }
  26387. /*<    15 XY( I)= XY( I)- SUM >*/
  26388. /* L15: */
  26389.         i__3 = i;
  26390.         i__1 = i;
  26391.         z__1.r = xy[i__1].r - sum.r, z__1.i = xy[i__1].i - sum.i;
  26392.         xy[i__3].r = z__1.r, xy[i__3].i = z__1.i;
  26393.     }
  26394. /*<    16 NI= NI+ NPBL >*/
  26395. /* L16: */
  26396.     ni += matpar_1.npbl;
  26397.     }
  26398. /*<       REWIND 14 >*/
  26399.     al__1.aerr = 0;
  26400.     al__1.aunit = 14;
  26401.     f_rew(&al__1);
  26402. /*     REORDER CURRENT ARRAY */
  26403. /*<       IF( N1.EQ. N.OR. M1.EQ.0) GOTO 20 >*/
  26404.     if (*n1 == *n || *m1 == 0) {
  26405.     goto L20;
  26406.     }
  26407. /*<       DO 17  I= N2, NPM >*/
  26408.     i__2 = npm;
  26409.     for (i = n2; i <= i__2; ++i) {
  26410. /*<    17 Y( I)= XY( I) >*/
  26411. /* L17: */
  26412.     i__3 = i - 1;
  26413.     i__1 = i;
  26414.     scratm_2.y[i__3].r = xy[i__1].r, scratm_2.y[i__3].i = xy[i__1].i;
  26415.     }
  26416. /*<       JJ= N1C+1 >*/
  26417.     jj = *n1c + 1;
  26418. /*<       J= N1 >*/
  26419.     j = *n1;
  26420. /*<       DO 18  I= JJ, NPM >*/
  26421.     i__3 = npm;
  26422.     for (i = jj; i <= i__3; ++i) {
  26423. /*<       J= J+1 >*/
  26424.     ++j;
  26425. /*<    18 XY( J)= Y( I) >*/
  26426. /* L18: */
  26427.     i__1 = j;
  26428.     i__2 = i - 1;
  26429.     xy[i__1].r = scratm_2.y[i__2].r, xy[i__1].i = scratm_2.y[i__2].i;
  26430.     }
  26431. /*<       DO 19  I= N2, N1C >*/
  26432.     i__1 = *n1c;
  26433.     for (i = n2; i <= i__1; ++i) {
  26434. /*<       J= J+1 >*/
  26435.     ++j;
  26436. /*<    19 XY( J)= Y( I) >*/
  26437. /* L19: */
  26438.     i__2 = j;
  26439.     i__3 = i - 1;
  26440.     xy[i__2].r = scratm_2.y[i__3].r, xy[i__2].i = scratm_2.y[i__3].i;
  26441.     }
  26442. /*<    20 IF( NSCON.EQ.0) GOTO 22 >*/
  26443. L20:
  26444.     if (segj_1.nscon == 0) {
  26445.     goto L22;
  26446.     }
  26447. /*<       J= NEQS-1 >*/
  26448.     j = neqs - 1;
  26449. /*<       DO 21  I=1, NSCON >*/
  26450.     i__2 = segj_1.nscon;
  26451.     for (i = 1; i <= i__2; ++i) {
  26452. /*<       J= J+1 >*/
  26453.     ++j;
  26454. /*<       JJ= ISCON( I) >*/
  26455.     jj = segj_1.iscon[i - 1];
  26456. /*<    21 XY( JJ)= XY( J) >*/
  26457. /* L21: */
  26458.     i__3 = jj;
  26459.     i__1 = j;
  26460.     xy[i__3].r = xy[i__1].r, xy[i__3].i = xy[i__1].i;
  26461.     }
  26462. /*<    22 RETURN >*/
  26463. L22:
  26464.     return 0;
  26465. /*<       END >*/
  26466. } /* solgf_ */
  26467.  
  26468. /* *** */
  26469. /*     DOUBLE PRECISION 6/4/85 */
  26470.  
  26471. /*<       SUBROUTINE SOLVE( N, A, IP, B, NDIM) >*/
  26472. /* Subroutine */ int solve_(n, a, ip, b, ndim)
  26473. integer *n;
  26474. doublecomplex *a;
  26475. integer *ip;
  26476. doublecomplex *b;
  26477. integer *ndim;
  26478. {
  26479.     /* System generated locals */
  26480.     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
  26481.     doublecomplex z__1, z__2;
  26482.  
  26483.     /* Builtin functions */
  26484.     void z_div();
  26485.  
  26486.     /* Local variables */
  26487.     static integer i, j, k, pi, ip1;
  26488.     static doublecomplex sum;
  26489.  
  26490. /* *** */
  26491.  
  26492. /*     SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT */
  26493.  
  26494. /*     LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH */
  26495.  
  26496. /*     OF WHICH ARE STORED IN A.  THE RHS VECTOR B IS INPUT AND THE */
  26497. /*     SOLUTION IS RETURNED THROUGH VECTOR B.    (MATRIX TRANSPOSED. */
  26498.  
  26499. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  26500. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  26501. /*<       COMPLEX  A, B, Y, SUM >*/
  26502. /*<       INTEGER  PI >*/
  26503. /*<       COMMON  /SCRATM/ Y( N2M) >*/
  26504.  
  26505. /*     FORWARD SUBSTITUTION */
  26506.  
  26507. /*<       DIMENSION  A( NDIM, NDIM), IP( NDIM), B( NDIM) >*/
  26508. /*<       DO 3  I=1, N >*/
  26509.     /* Parameter adjustments */
  26510.     --b;
  26511.     --ip;
  26512.     a_dim1 = *ndim;
  26513.     a_offset = a_dim1 + 1;
  26514.     a -= a_offset;
  26515.  
  26516.     /* Function Body */
  26517.     i__1 = *n;
  26518.     for (i = 1; i <= i__1; ++i) {
  26519. /*<       PI= IP( I) >*/
  26520.     pi = ip[i];
  26521. /*<       Y( I)= B( PI) >*/
  26522.     i__2 = i - 1;
  26523.     i__3 = pi;
  26524.     scratm_2.y[i__2].r = b[i__3].r, scratm_2.y[i__2].i = b[i__3].i;
  26525. /*<       B( PI)= B( I) >*/
  26526.     i__2 = pi;
  26527.     i__3 = i;
  26528.     b[i__2].r = b[i__3].r, b[i__2].i = b[i__3].i;
  26529. /*<       IP1= I+1 >*/
  26530.     ip1 = i + 1;
  26531. /*<       IF( IP1.GT. N) GOTO 2 >*/
  26532.     if (ip1 > *n) {
  26533.         goto L2;
  26534.     }
  26535. /*<       DO 1  J= IP1, N >*/
  26536.     i__2 = *n;
  26537.     for (j = ip1; j <= i__2; ++j) {
  26538. /*<       B( J)= B( J)- A( I, J)* Y( I) >*/
  26539.         i__3 = j;
  26540.         i__4 = j;
  26541.         i__5 = i + j * a_dim1;
  26542.         i__6 = i - 1;
  26543.         z__2.r = a[i__5].r * scratm_2.y[i__6].r - a[i__5].i * scratm_2.y[
  26544.             i__6].i, z__2.i = a[i__5].r * scratm_2.y[i__6].i + a[i__5]
  26545.             .i * scratm_2.y[i__6].r;
  26546.         z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
  26547.         b[i__3].r = z__1.r, b[i__3].i = z__1.i;
  26548. /*<     1 CONTINUE >*/
  26549. /* L1: */
  26550.     }
  26551. /*<     2 CONTINUE >*/
  26552. L2:
  26553.  
  26554. /*     BACKWARD SUBSTITUTION */
  26555.  
  26556. /*<     3 CONTINUE >*/
  26557. /* L3: */
  26558.     ;
  26559.     }
  26560. /*<       DO 6  K=1, N >*/
  26561.     i__1 = *n;
  26562.     for (k = 1; k <= i__1; ++k) {
  26563. /*<       I= N- K+1 >*/
  26564.     i = *n - k + 1;
  26565. /*<       SUM=(0.,0.) >*/
  26566.     sum.r = 0., sum.i = 0.;
  26567. /*<       IP1= I+1 >*/
  26568.     ip1 = i + 1;
  26569. /*<       IF( IP1.GT. N) GOTO 5 >*/
  26570.     if (ip1 > *n) {
  26571.         goto L5;
  26572.     }
  26573. /*<       DO 4  J= IP1, N >*/
  26574.     i__2 = *n;
  26575.     for (j = ip1; j <= i__2; ++j) {
  26576. /*<       SUM= SUM+ A( J, I)* B( J) >*/
  26577.         i__3 = j + i * a_dim1;
  26578.         i__4 = j;
  26579.         z__2.r = a[i__3].r * b[i__4].r - a[i__3].i * b[i__4].i, z__2.i = 
  26580.             a[i__3].r * b[i__4].i + a[i__3].i * b[i__4].r;
  26581.         z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  26582.         sum.r = z__1.r, sum.i = z__1.i;
  26583. /*<     4 CONTINUE >*/
  26584. /* L4: */
  26585.     }
  26586. /*<     5 CONTINUE >*/
  26587. L5:
  26588. /*<       B( I)=( Y( I)- SUM)/ A( I, I) >*/
  26589.     i__2 = i;
  26590.     i__3 = i - 1;
  26591.     z__2.r = scratm_2.y[i__3].r - sum.r, z__2.i = scratm_2.y[i__3].i - 
  26592.         sum.i;
  26593.     z_div(&z__1, &z__2, &a[i + i * a_dim1]);
  26594.     b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  26595. /*<     6 CONTINUE >*/
  26596. /* L6: */
  26597.     }
  26598. /*<       RETURN >*/
  26599.     return 0;
  26600. /*<       END >*/
  26601. } /* solve_ */
  26602.  
  26603. /* *** */
  26604. /*     DOUBLE PRECISION 6/4/85 */
  26605.  
  26606. /*<       SUBROUTINE SOLVES( A, IP, B, NEQ, NRH, NP, N, MP, M, IFL1, IFL2) >*/
  26607. /* Subroutine */ int solves_(a, ip, b, neq, nrh, np, n, mp, m, ifl1, ifl2)
  26608. doublecomplex *a;
  26609. integer *ip;
  26610. doublecomplex *b;
  26611. integer *neq, *nrh, *np, *n, *mp, *m, *ifl1, *ifl2;
  26612. {
  26613.     /* System generated locals */
  26614.     integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
  26615.     doublecomplex z__1, z__2, z__3;
  26616.     alist al__1;
  26617.  
  26618.     /* Builtin functions */
  26619.     void d_cnjg();
  26620.     integer f_rew(), s_rsue(), do_uio(), e_rsue();
  26621.  
  26622.     /* Local variables */
  26623.     static doublereal fnop;
  26624.     static integer npeq, nrow, i, j, k;
  26625.     static doublereal fnorm;
  26626.     extern /* Subroutine */ int solve_();
  26627.     static integer ia, ib, ic, kk;
  26628.     extern /* Subroutine */ int ltsolv_();
  26629.     static integer nop;
  26630.     static doublecomplex sum;
  26631.  
  26632.     /* Fortran I/O blocks */
  26633.     static cilist io___2056 = { 0, 0, 0, 0, 0 };
  26634.  
  26635.  
  26636. /* *** */
  26637.  
  26638. /*     SUBROUTINE SOLVES, FOR SYMMETRIC STRUCTURES, HANDLES THE */
  26639. /*     TRANSFORMATION OF THE RIGHT HAND SIDE VECTOR AND SOLUTION OF THE */
  26640.  
  26641. /*     MATRIX EQ. */
  26642.  
  26643. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  26644. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  26645. /*<       COMPLEX  A, B, Y, SUM, SSX >*/
  26646. /*<       COMMON  /SMAT/ SSX(16,16) >*/
  26647. /*<       COMMON  /SCRATM/ Y( N2M) >*/
  26648. /*<    >*/
  26649. /*<       DIMENSION  A(1), IP(1), B( NEQ, NRH) >*/
  26650. /*<       NPEQ= NP+2* MP >*/
  26651.     /* Parameter adjustments */
  26652.     b_dim1 = *neq;
  26653.     b_offset = b_dim1 + 1;
  26654.     b -= b_offset;
  26655.     --ip;
  26656.     --a;
  26657.  
  26658.     /* Function Body */
  26659.     npeq = *np + (*mp << 1);
  26660. /*<       NOP= NEQ/ NPEQ >*/
  26661.     nop = *neq / npeq;
  26662. /*<       FNOP= NOP >*/
  26663.     fnop = (doublereal) nop;
  26664. /*<       FNORM=1./ FNOP >*/
  26665.     fnorm = 1. / fnop;
  26666. /*<       NROW= NEQ >*/
  26667.     nrow = *neq;
  26668. /*<       IF( ICASE.GT.3) NROW= NPEQ >*/
  26669.     if (matpar_1.icase > 3) {
  26670.     nrow = npeq;
  26671.     }
  26672. /*<       IF( NOP.EQ.1) GOTO 11 >*/
  26673.     if (nop == 1) {
  26674.     goto L11;
  26675.     }
  26676. /*<       DO 10  IC=1, NRH >*/
  26677.     i__1 = *nrh;
  26678.     for (ic = 1; ic <= i__1; ++ic) {
  26679. /*<       IF( N.EQ.0.OR. M.EQ.0) GOTO 6 >*/
  26680.     if (*n == 0 || *m == 0) {
  26681.         goto L6;
  26682.     }
  26683. /*<       DO 1  I=1, NEQ >*/
  26684.     i__2 = *neq;
  26685.     for (i = 1; i <= i__2; ++i) {
  26686. /*<     1 Y( I)= B( I, IC) >*/
  26687. /* L1: */
  26688.         i__3 = i - 1;
  26689.         i__4 = i + ic * b_dim1;
  26690.         scratm_2.y[i__3].r = b[i__4].r, scratm_2.y[i__3].i = b[i__4].i;
  26691.     }
  26692. /*<       KK=2* MP >*/
  26693.     kk = *mp << 1;
  26694. /*<       IA= NP >*/
  26695.     ia = *np;
  26696. /*<       IB= N >*/
  26697.     ib = *n;
  26698. /*<       J= NP >*/
  26699.     j = *np;
  26700. /*<       DO 5  K=1, NOP >*/
  26701.     i__3 = nop;
  26702.     for (k = 1; k <= i__3; ++k) {
  26703. /*<       IF( K.EQ.1) GOTO 3 >*/
  26704.         if (k == 1) {
  26705.         goto L3;
  26706.         }
  26707. /*<       DO 2  I=1, NP >*/
  26708.         i__4 = *np;
  26709.         for (i = 1; i <= i__4; ++i) {
  26710. /*<       IA= IA+1 >*/
  26711.         ++ia;
  26712. /*<       J= J+1 >*/
  26713.         ++j;
  26714. /*<     2 B( J, IC)= Y( IA) >*/
  26715. /* L2: */
  26716.         i__2 = j + ic * b_dim1;
  26717.         i__5 = ia - 1;
  26718.         b[i__2].r = scratm_2.y[i__5].r, b[i__2].i = scratm_2.y[i__5]
  26719.             .i;
  26720.         }
  26721. /*<       IF( K.EQ. NOP) GOTO 5 >*/
  26722.         if (k == nop) {
  26723.         goto L5;
  26724.         }
  26725. /*<     3 DO 4  I=1, KK >*/
  26726. L3:
  26727.         i__2 = kk;
  26728.         for (i = 1; i <= i__2; ++i) {
  26729. /*<       IB= IB+1 >*/
  26730.         ++ib;
  26731. /*<       J= J+1 >*/
  26732.         ++j;
  26733. /*<     4 B( J, IC)= Y( IB) >*/
  26734. /* L4: */
  26735.         i__5 = j + ic * b_dim1;
  26736.         i__4 = ib - 1;
  26737.         b[i__5].r = scratm_2.y[i__4].r, b[i__5].i = scratm_2.y[i__4]
  26738.             .i;
  26739.         }
  26740.  
  26741. /*     TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES
  26742.  */
  26743.  
  26744. /*<     5 CONTINUE >*/
  26745. L5:
  26746.         ;
  26747.     }
  26748. /*<     6 DO 10  I=1, NPEQ >*/
  26749. L6:
  26750.     i__3 = npeq;
  26751.     for (i = 1; i <= i__3; ++i) {
  26752. /*<       DO 7  K=1, NOP >*/
  26753.         i__5 = nop;
  26754.         for (k = 1; k <= i__5; ++k) {
  26755. /*<       IA= I+( K-1)* NPEQ >*/
  26756.         ia = i + (k - 1) * npeq;
  26757. /*<     7 Y( K)= B( IA, IC) >*/
  26758. /* L7: */
  26759.         i__4 = k - 1;
  26760.         i__2 = ia + ic * b_dim1;
  26761.         scratm_2.y[i__4].r = b[i__2].r, scratm_2.y[i__4].i = b[i__2]
  26762.             .i;
  26763.         }
  26764. /*<       SUM= Y(1) >*/
  26765.         sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
  26766. /*<       DO 8  K=2, NOP >*/
  26767.         i__4 = nop;
  26768.         for (k = 2; k <= i__4; ++k) {
  26769. /*<     8 SUM= SUM+ Y( K) >*/
  26770. /* L8: */
  26771.         i__2 = k - 1;
  26772.         z__1.r = sum.r + scratm_2.y[i__2].r, z__1.i = sum.i + 
  26773.             scratm_2.y[i__2].i;
  26774.         sum.r = z__1.r, sum.i = z__1.i;
  26775.         }
  26776. /*<       B( I, IC)= SUM* FNORM >*/
  26777.         i__2 = i + ic * b_dim1;
  26778.         z__1.r = fnorm * sum.r, z__1.i = fnorm * sum.i;
  26779.         b[i__2].r = z__1.r, b[i__2].i = z__1.i;
  26780. /*<       DO 10  K=2, NOP >*/
  26781.         i__2 = nop;
  26782.         for (k = 2; k <= i__2; ++k) {
  26783. /*<       IA= I+( K-1)* NPEQ >*/
  26784.         ia = i + (k - 1) * npeq;
  26785. /*<       SUM= Y(1) >*/
  26786.         sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
  26787. /*<       DO 9  J=2, NOP >*/
  26788.         i__4 = nop;
  26789.         for (j = 2; j <= i__4; ++j) {
  26790. /*<     9 SUM= SUM+ Y( J)* CONJG( SSX( K, J)) >*/
  26791. /* L9: */
  26792.             i__5 = j - 1;
  26793.             d_cnjg(&z__3, &smat_1.ssx[k + (j << 4) - 17]);
  26794.             z__2.r = scratm_2.y[i__5].r * z__3.r - scratm_2.y[i__5].i 
  26795.                 * z__3.i, z__2.i = scratm_2.y[i__5].r * z__3.i + 
  26796.                 scratm_2.y[i__5].i * z__3.r;
  26797.             z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  26798.             sum.r = z__1.r, sum.i = z__1.i;
  26799.         }
  26800. /*<    10 B( IA, IC)= SUM* FNORM >*/
  26801. /* L10: */
  26802.         i__5 = ia + ic * b_dim1;
  26803.         z__1.r = fnorm * sum.r, z__1.i = fnorm * sum.i;
  26804.         b[i__5].r = z__1.r, b[i__5].i = z__1.i;
  26805.         }
  26806.     }
  26807.     }
  26808. /*<    11 IF( ICASE.LT.3) GOTO 12 >*/
  26809. L11:
  26810.     if (matpar_1.icase < 3) {
  26811.     goto L12;
  26812.     }
  26813. /*<       REWIND IFL1 >*/
  26814.     al__1.aerr = 0;
  26815.     al__1.aunit = *ifl1;
  26816.     f_rew(&al__1);
  26817.  
  26818. /*     SOLVE EACH MODE EQUATION */
  26819.  
  26820. /*<       REWIND IFL2 >*/
  26821.     al__1.aerr = 0;
  26822.     al__1.aunit = *ifl2;
  26823.     f_rew(&al__1);
  26824. /*<    12 DO 16  KK=1, NOP >*/
  26825. L12:
  26826.     i__5 = nop;
  26827.     for (kk = 1; kk <= i__5; ++kk) {
  26828. /*<       IA=( KK-1)* NPEQ+1 >*/
  26829.     ia = (kk - 1) * npeq + 1;
  26830. /*<       IB= IA >*/
  26831.     ib = ia;
  26832. /*<       IF( ICASE.NE.4) GOTO 13 >*/
  26833.     if (matpar_1.icase != 4) {
  26834.         goto L13;
  26835.     }
  26836. /*<       I= NPEQ* NPEQ >*/
  26837.     i = npeq * npeq;
  26838. /*<       READ( IFL1) ( A( J), J=1, I) >*/
  26839.     io___2056.ciunit = *ifl1;
  26840.     s_rsue(&io___2056);
  26841.     i__2 = i;
  26842.     for (j = 1; j <= i__2; ++j) {
  26843.         do_uio(&c__2, (char *)&a[j], (ftnlen)sizeof(doublereal));
  26844.     }
  26845.     e_rsue();
  26846. /*<       IB=1 >*/
  26847.     ib = 1;
  26848. /*<    13 IF( ICASE.EQ.3.OR. ICASE.EQ.5) GOTO 15 >*/
  26849. L13:
  26850.     if (matpar_1.icase == 3 || matpar_1.icase == 5) {
  26851.         goto L15;
  26852.     }
  26853. /*<       DO 14  IC=1, NRH >*/
  26854.     i__2 = *nrh;
  26855.     for (ic = 1; ic <= i__2; ++ic) {
  26856. /*<    14 CALL SOLVE( NPEQ, A( IB), IP( IA), B( IA, IC), NROW) >*/
  26857. /* L14: */
  26858.         solve_(&npeq, &a[ib], &ip[ia], &b[ia + ic * b_dim1], &nrow);
  26859.     }
  26860. /*<       GOTO 16 >*/
  26861.     goto L16;
  26862. /*<    15 CALL LTSOLV( A, NPEQ, IP( IA), B( IA,1), NEQ, NRH, IFL1, IFL2) >*/
  26863. L15:
  26864.     ltsolv_(&a[1], &npeq, &ip[ia], &b[ia + b_dim1], neq, nrh, ifl1, ifl2);
  26865.  
  26866. /*<    16 CONTINUE >*/
  26867. L16:
  26868.     ;
  26869.     }
  26870.  
  26871. /*     INVERSE TRANSFORM THE MODE SOLUTIONS */
  26872.  
  26873. /*<       IF( NOP.EQ.1) RETURN >*/
  26874.     if (nop == 1) {
  26875.     return 0;
  26876.     }
  26877. /*<       DO 26  IC=1, NRH >*/
  26878.     i__5 = *nrh;
  26879.     for (ic = 1; ic <= i__5; ++ic) {
  26880. /*<       DO 20  I=1, NPEQ >*/
  26881.     i__2 = npeq;
  26882.     for (i = 1; i <= i__2; ++i) {
  26883. /*<       DO 17  K=1, NOP >*/
  26884.         i__3 = nop;
  26885.         for (k = 1; k <= i__3; ++k) {
  26886. /*<       IA= I+( K-1)* NPEQ >*/
  26887.         ia = i + (k - 1) * npeq;
  26888. /*<    17 Y( K)= B( IA, IC) >*/
  26889. /* L17: */
  26890.         i__1 = k - 1;
  26891.         i__4 = ia + ic * b_dim1;
  26892.         scratm_2.y[i__1].r = b[i__4].r, scratm_2.y[i__1].i = b[i__4]
  26893.             .i;
  26894.         }
  26895. /*<       SUM= Y(1) >*/
  26896.         sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
  26897. /*<       DO 18  K=2, NOP >*/
  26898.         i__1 = nop;
  26899.         for (k = 2; k <= i__1; ++k) {
  26900. /*<    18 SUM= SUM+ Y( K) >*/
  26901. /* L18: */
  26902.         i__4 = k - 1;
  26903.         z__1.r = sum.r + scratm_2.y[i__4].r, z__1.i = sum.i + 
  26904.             scratm_2.y[i__4].i;
  26905.         sum.r = z__1.r, sum.i = z__1.i;
  26906.         }
  26907. /*<       B( I, IC)= SUM >*/
  26908.         i__4 = i + ic * b_dim1;
  26909.         b[i__4].r = sum.r, b[i__4].i = sum.i;
  26910. /*<       DO 20  K=2, NOP >*/
  26911.         i__4 = nop;
  26912.         for (k = 2; k <= i__4; ++k) {
  26913. /*<       IA= I+( K-1)* NPEQ >*/
  26914.         ia = i + (k - 1) * npeq;
  26915. /*<       SUM= Y(1) >*/
  26916.         sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
  26917. /*<       DO 19  J=2, NOP >*/
  26918.         i__1 = nop;
  26919.         for (j = 2; j <= i__1; ++j) {
  26920. /*<    19 SUM= SUM+ Y( J)* SSX( K, J) >*/
  26921. /* L19: */
  26922.             i__3 = j - 1;
  26923.             i__6 = k + (j << 4) - 17;
  26924.             z__2.r = scratm_2.y[i__3].r * smat_1.ssx[i__6].r - 
  26925.                 scratm_2.y[i__3].i * smat_1.ssx[i__6].i, z__2.i = 
  26926.                 scratm_2.y[i__3].r * smat_1.ssx[i__6].i + 
  26927.                 scratm_2.y[i__3].i * smat_1.ssx[i__6].r;
  26928.             z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
  26929.             sum.r = z__1.r, sum.i = z__1.i;
  26930.         }
  26931. /*<    20 B( IA, IC)= SUM >*/
  26932. /* L20: */
  26933.         i__3 = ia + ic * b_dim1;
  26934.         b[i__3].r = sum.r, b[i__3].i = sum.i;
  26935.         }
  26936.     }
  26937. /*<       IF( N.EQ.0.OR. M.EQ.0) GOTO 26 >*/
  26938.     if (*n == 0 || *m == 0) {
  26939.         goto L26;
  26940.     }
  26941. /*<       DO 21  I=1, NEQ >*/
  26942.     i__3 = *neq;
  26943.     for (i = 1; i <= i__3; ++i) {
  26944. /*<    21 Y( I)= B( I, IC) >*/
  26945. /* L21: */
  26946.         i__4 = i - 1;
  26947.         i__2 = i + ic * b_dim1;
  26948.         scratm_2.y[i__4].r = b[i__2].r, scratm_2.y[i__4].i = b[i__2].i;
  26949.     }
  26950. /*<       KK=2* MP >*/
  26951.     kk = *mp << 1;
  26952. /*<       IA= NP >*/
  26953.     ia = *np;
  26954. /*<       IB= N >*/
  26955.     ib = *n;
  26956. /*<       J= NP >*/
  26957.     j = *np;
  26958. /*<       DO 25  K=1, NOP >*/
  26959.     i__4 = nop;
  26960.     for (k = 1; k <= i__4; ++k) {
  26961. /*<       IF( K.EQ.1) GOTO 23 >*/
  26962.         if (k == 1) {
  26963.         goto L23;
  26964.         }
  26965. /*<       DO 22  I=1, NP >*/
  26966.         i__2 = *np;
  26967.         for (i = 1; i <= i__2; ++i) {
  26968. /*<       IA= IA+1 >*/
  26969.         ++ia;
  26970. /*<       J= J+1 >*/
  26971.         ++j;
  26972. /*<    22 B( IA, IC)= Y( J) >*/
  26973. /* L22: */
  26974.         i__3 = ia + ic * b_dim1;
  26975.         i__6 = j - 1;
  26976.         b[i__3].r = scratm_2.y[i__6].r, b[i__3].i = scratm_2.y[i__6]
  26977.             .i;
  26978.         }
  26979. /*<       IF( K.EQ. NOP) GOTO 25 >*/
  26980.         if (k == nop) {
  26981.         goto L25;
  26982.         }
  26983. /*<    23 DO 24  I=1, KK >*/
  26984. L23:
  26985.         i__3 = kk;
  26986.         for (i = 1; i <= i__3; ++i) {
  26987. /*<       IB= IB+1 >*/
  26988.         ++ib;
  26989. /*<       J= J+1 >*/
  26990.         ++j;
  26991. /*<    24 B( IB, IC)= Y( J) >*/
  26992. /* L24: */
  26993.         i__6 = ib + ic * b_dim1;
  26994.         i__2 = j - 1;
  26995.         b[i__6].r = scratm_2.y[i__2].r, b[i__6].i = scratm_2.y[i__2]
  26996.             .i;
  26997.         }
  26998. /*<    25 CONTINUE >*/
  26999. L25:
  27000.         ;
  27001.     }
  27002. /*<    26 CONTINUE >*/
  27003. L26:
  27004.     ;
  27005.     }
  27006. /*<       RETURN >*/
  27007.     return 0;
  27008. /*<       END >*/
  27009. } /* solves_ */
  27010.  
  27011. /* *** */
  27012. /*     DOUBLE PRECISION 6/4/85 */
  27013.  
  27014. /*<       SUBROUTINE TBF( I, ICAP) >*/
  27015. /* Subroutine */ int tbf_(i, icap)
  27016. integer *i, *icap;
  27017. {
  27018.     /* Initialized data */
  27019.  
  27020.     static doublereal pi = 3.141592654;
  27021.     static integer jmax = 30;
  27022.  
  27023.     /* Format strings */
  27024.     static char fmt_29[] = "(\002 TBF - SEGMENT CONNECTION ERROR FOR SEGMEN\
  27025. T\002,i5)";
  27026.  
  27027.     /* System generated locals */
  27028.     integer i__1;
  27029.     doublereal d__1;
  27030.  
  27031.     /* Builtin functions */
  27032.     double sin(), cos(), log();
  27033.     integer s_wsfe(), do_fio(), e_wsfe();
  27034.     /* Subroutine */ int s_stop();
  27035.  
  27036.     /* Local variables */
  27037.     static integer iend, jend, jcox, njun1, njun2;
  27038.     static doublereal d;
  27039.     static integer jsnop;
  27040.     static doublereal cd, aj, ap, sd, pp, pm, qp, qm, cdh, sdh, omc, sig, xxi;
  27041.  
  27042.  
  27043.     /* Fortran I/O blocks */
  27044.     static cilist io___2079 = { 0, 6, 0, fmt_29, 0 };
  27045.  
  27046.  
  27047. /* *** */
  27048. /*     COMPUTE BASIS FUNCTION I */
  27049. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  27050. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  27051. /*<    >*/
  27052. /*<    >*/
  27053. /*<       DATA   PI/3.141592654D+0/, JMAX/30/ >*/
  27054. /*<       JSNO=0 >*/
  27055.     segj_1.jsno = 0;
  27056. /*<       PP=0. >*/
  27057.     pp = 0.;
  27058. /*<       JCOX= ICON1( I) >*/
  27059.     jcox = data_1.icon1[*i - 1];
  27060. /*<       IF( JCOX.GT.10000) JCOX= I >*/
  27061.     if (jcox > 10000) {
  27062.     jcox = *i;
  27063.     }
  27064. /*<       JEND=-1 >*/
  27065.     jend = -1;
  27066. /*<       IEND=-1 >*/
  27067.     iend = -1;
  27068. /*<       SIG=-1. >*/
  27069.     sig = -1.;
  27070. /*<       IF( JCOX) 1,10,2 >*/
  27071.     if (jcox < 0) {
  27072.     goto L1;
  27073.     } else if (jcox == 0) {
  27074.     goto L10;
  27075.     } else {
  27076.     goto L2;
  27077.     }
  27078. /*<     1 JCOX=- JCOX >*/
  27079. L1:
  27080.     jcox = -jcox;
  27081. /*<       GOTO 3 >*/
  27082.     goto L3;
  27083. /*<     2 SIG=- SIG >*/
  27084. L2:
  27085.     sig = -sig;
  27086. /*<       JEND=- JEND >*/
  27087.     jend = -jend;
  27088. /*<     3 JSNO= JSNO+1 >*/
  27089. L3:
  27090.     ++segj_1.jsno;
  27091. /*<       IF( JSNO.GE. JMAX) GOTO 28 >*/
  27092.     if (segj_1.jsno >= jmax) {
  27093.     goto L28;
  27094.     }
  27095. /*<       JCO( JSNO)= JCOX >*/
  27096.     segj_1.jco[segj_1.jsno - 1] = jcox;
  27097. /*<       D= PI* SI( JCOX) >*/
  27098.     d = pi * data_1.si[jcox - 1];
  27099. /*<       SDH= SIN( D) >*/
  27100.     sdh = sin(d);
  27101. /*<       CDH= COS( D) >*/
  27102.     cdh = cos(d);
  27103. /*<       SD=2.* SDH* CDH >*/
  27104.     d__1 = sdh * 2.;
  27105.     sd = d__1 * cdh;
  27106. /*<       IF( D.GT.0.015) GOTO 4 >*/
  27107.     if (d > .015) {
  27108.     goto L4;
  27109.     }
  27110. /*<       OMC=4.* D* D >*/
  27111.     d__1 = d * 4.;
  27112.     omc = d__1 * d;
  27113. /*<       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
  27114.     omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
  27115. /*<       GOTO 5 >*/
  27116.     goto L5;
  27117. /*<     4 OMC=1.- CDH* CDH+ SDH* SDH >*/
  27118. L4:
  27119.     omc = 1. - cdh * cdh + sdh * sdh;
  27120. /*<     5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0) >*/
  27121. L5:
  27122.     aj = 1. / (log(1. / (pi * data_1.bi[jcox - 1])) - .577215664);
  27123. /*<       PP= PP- OMC/ SD* AJ >*/
  27124.     pp -= omc / sd * aj;
  27125. /*<       AX( JSNO)= AJ/ SD* SIG >*/
  27126.     segj_1.ax[segj_1.jsno - 1] = aj / sd * sig;
  27127. /*<       BX( JSNO)= AJ/(2.* CDH) >*/
  27128.     segj_1.bx[segj_1.jsno - 1] = aj / (cdh * 2.);
  27129. /*<       CX( JSNO)=- AJ/(2.* SDH)* SIG >*/
  27130.     segj_1.cx[segj_1.jsno - 1] = -aj / (sdh * 2.) * sig;
  27131. /*<       IF( JCOX.EQ. I) GOTO 8 >*/
  27132.     if (jcox == *i) {
  27133.     goto L8;
  27134.     }
  27135. /*<       IF( JEND.EQ.1) GOTO 6 >*/
  27136.     if (jend == 1) {
  27137.     goto L6;
  27138.     }
  27139. /*<       JCOX= ICON1( JCOX) >*/
  27140.     jcox = data_1.icon1[jcox - 1];
  27141. /*<       GOTO 7 >*/
  27142.     goto L7;
  27143. /*<     6 JCOX= ICON2( JCOX) >*/
  27144. L6:
  27145.     jcox = data_1.icon2[jcox - 1];
  27146. /*<     7 IF( IABS( JCOX).EQ. I) GOTO 9 >*/
  27147. L7:
  27148.     if (abs(jcox) == *i) {
  27149.     goto L9;
  27150.     }
  27151. /*<       IF( JCOX) 1,28,2 >*/
  27152.     if (jcox < 0) {
  27153.     goto L1;
  27154.     } else if (jcox == 0) {
  27155.     goto L28;
  27156.     } else {
  27157.     goto L2;
  27158.     }
  27159. /*<     8 BX( JSNO)=- BX( JSNO) >*/
  27160. L8:
  27161.     segj_1.bx[segj_1.jsno - 1] = -segj_1.bx[segj_1.jsno - 1];
  27162. /*<     9 IF( IEND.EQ.1) GOTO 11 >*/
  27163. L9:
  27164.     if (iend == 1) {
  27165.     goto L11;
  27166.     }
  27167. /*<    10 PM=- PP >*/
  27168. L10:
  27169.     pm = -pp;
  27170. /*<       PP=0. >*/
  27171.     pp = 0.;
  27172. /*<       NJUN1= JSNO >*/
  27173.     njun1 = segj_1.jsno;
  27174. /*<       JCOX= ICON2( I) >*/
  27175.     jcox = data_1.icon2[*i - 1];
  27176. /*<       IF( JCOX.GT.10000) JCOX= I >*/
  27177.     if (jcox > 10000) {
  27178.     jcox = *i;
  27179.     }
  27180. /*<       JEND=1 >*/
  27181.     jend = 1;
  27182. /*<       IEND=1 >*/
  27183.     iend = 1;
  27184. /*<       SIG=-1. >*/
  27185.     sig = -1.;
  27186. /*<       IF( JCOX) 1,11,2 >*/
  27187.     if (jcox < 0) {
  27188.     goto L1;
  27189.     } else if (jcox == 0) {
  27190.     goto L11;
  27191.     } else {
  27192.     goto L2;
  27193.     }
  27194. /*<    11 NJUN2= JSNO- NJUN1 >*/
  27195. L11:
  27196.     njun2 = segj_1.jsno - njun1;
  27197. /*<       JSNOP= JSNO+1 >*/
  27198.     jsnop = segj_1.jsno + 1;
  27199. /*<       JCO( JSNOP)= I >*/
  27200.     segj_1.jco[jsnop - 1] = *i;
  27201. /*<       D= PI* SI( I) >*/
  27202.     d = pi * data_1.si[*i - 1];
  27203. /*<       SDH= SIN( D) >*/
  27204.     sdh = sin(d);
  27205. /*<       CDH= COS( D) >*/
  27206.     cdh = cos(d);
  27207. /*<       SD=2.* SDH* CDH >*/
  27208.     d__1 = sdh * 2.;
  27209.     sd = d__1 * cdh;
  27210. /*<       CD= CDH* CDH- SDH* SDH >*/
  27211.     cd = cdh * cdh - sdh * sdh;
  27212. /*<       IF( D.GT.0.015) GOTO 12 >*/
  27213.     if (d > .015) {
  27214.     goto L12;
  27215.     }
  27216. /*<       OMC=4.* D* D >*/
  27217.     d__1 = d * 4.;
  27218.     omc = d__1 * d;
  27219. /*<       OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
  27220.     omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
  27221. /*<       GOTO 13 >*/
  27222.     goto L13;
  27223. /*<    12 OMC=1.- CD >*/
  27224. L12:
  27225.     omc = 1. - cd;
  27226. /*<    13 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0) >*/
  27227. L13:
  27228.     ap = 1. / (log(1. / (pi * data_1.bi[*i - 1])) - .577215664);
  27229. /*<       AJ= AP >*/
  27230.     aj = ap;
  27231. /*<       IF( NJUN1.EQ.0) GOTO 16 >*/
  27232.     if (njun1 == 0) {
  27233.     goto L16;
  27234.     }
  27235. /*<       IF( NJUN2.EQ.0) GOTO 20 >*/
  27236.     if (njun2 == 0) {
  27237.     goto L20;
  27238.     }
  27239. /*<       QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ) >*/
  27240.     qp = sd * (pm * pp + aj * ap) + cd * (pm * ap - pp * aj);
  27241. /*<       QM=( AP* OMC- PP* SD)/ QP >*/
  27242.     qm = (ap * omc - pp * sd) / qp;
  27243. /*<       QP=-( AJ* OMC+ PM* SD)/ QP >*/
  27244.     qp = -(aj * omc + pm * sd) / qp;
  27245. /*<       BX( JSNOP)=( AJ* QM+ AP* QP)* SDH/ SD >*/
  27246.     segj_1.bx[jsnop - 1] = (aj * qm + ap * qp) * sdh / sd;
  27247. /*<       CX( JSNOP)=( AJ* QM- AP* QP)* CDH/ SD >*/
  27248.     segj_1.cx[jsnop - 1] = (aj * qm - ap * qp) * cdh / sd;
  27249. /*<       DO 14  IEND=1, NJUN1 >*/
  27250.     i__1 = njun1;
  27251.     for (iend = 1; iend <= i__1; ++iend) {
  27252. /*<       AX( IEND)= AX( IEND)* QM >*/
  27253.     segj_1.ax[iend - 1] *= qm;
  27254. /*<       BX( IEND)= BX( IEND)* QM >*/
  27255.     segj_1.bx[iend - 1] *= qm;
  27256. /*<    14 CX( IEND)= CX( IEND)* QM >*/
  27257. /* L14: */
  27258.     segj_1.cx[iend - 1] *= qm;
  27259.     }
  27260. /*<       JEND= NJUN1+1 >*/
  27261.     jend = njun1 + 1;
  27262. /*<       DO 15  IEND= JEND, JSNO >*/
  27263.     i__1 = segj_1.jsno;
  27264.     for (iend = jend; iend <= i__1; ++iend) {
  27265. /*<       AX( IEND)=- AX( IEND)* QP >*/
  27266.     segj_1.ax[iend - 1] = -segj_1.ax[iend - 1] * qp;
  27267. /*<       BX( IEND)= BX( IEND)* QP >*/
  27268.     segj_1.bx[iend - 1] *= qp;
  27269. /*<    15 CX( IEND)=- CX( IEND)* QP >*/
  27270. /* L15: */
  27271.     segj_1.cx[iend - 1] = -segj_1.cx[iend - 1] * qp;
  27272.     }
  27273. /*<       GOTO 27 >*/
  27274.     goto L27;
  27275. /*<    16 IF( NJUN2.EQ.0) GOTO 24 >*/
  27276. L16:
  27277.     if (njun2 == 0) {
  27278.     goto L24;
  27279.     }
  27280. /*<       IF( ICAP.NE.0) GOTO 17 >*/
  27281.     if (*icap != 0) {
  27282.     goto L17;
  27283.     }
  27284. /*<       XXI=0. >*/
  27285.     xxi = 0.;
  27286. /*<       GOTO 18 >*/
  27287.     goto L18;
  27288. /*<    17 QP= PI* BI( I) >*/
  27289. L17:
  27290.     qp = pi * data_1.bi[*i - 1];
  27291. /*<       XXI= QP* QP >*/
  27292.     xxi = qp * qp;
  27293. /*<       XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
  27294.     xxi = qp * (1. - xxi * .5) / (1. - xxi);
  27295. /*<    18 QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP)) >*/
  27296. L18:
  27297.     qp = -(omc + xxi * sd) / (sd * (ap + xxi * pp) + cd * (xxi * ap - pp));
  27298. /*<       D= CD- XXI* SD >*/
  27299.     d = cd - xxi * sd;
  27300. /*<       BX( JSNOP)=( SDH+ AP* QP*( CDH- XXI* SDH))/ D >*/
  27301.     d__1 = ap * qp;
  27302.     segj_1.bx[jsnop - 1] = (sdh + d__1 * (cdh - xxi * sdh)) / d;
  27303. /*<       CX( JSNOP)=( CDH+ AP* QP*( SDH+ XXI* CDH))/ D >*/
  27304.     d__1 = ap * qp;
  27305.     segj_1.cx[jsnop - 1] = (cdh + d__1 * (sdh + xxi * cdh)) / d;
  27306. /*<       DO 19  IEND=1, NJUN2 >*/
  27307.     i__1 = njun2;
  27308.     for (iend = 1; iend <= i__1; ++iend) {
  27309. /*<       AX( IEND)=- AX( IEND)* QP >*/
  27310.     segj_1.ax[iend - 1] = -segj_1.ax[iend - 1] * qp;
  27311. /*<       BX( IEND)= BX( IEND)* QP >*/
  27312.     segj_1.bx[iend - 1] *= qp;
  27313. /*<    19 CX( IEND)=- CX( IEND)* QP >*/
  27314. /* L19: */
  27315.     segj_1.cx[iend - 1] = -segj_1.cx[iend - 1] * qp;
  27316.     }
  27317. /*<       GOTO 27 >*/
  27318.     goto L27;
  27319. /*<    20 IF( ICAP.NE.0) GOTO 21 >*/
  27320. L20:
  27321.     if (*icap != 0) {
  27322.     goto L21;
  27323.     }
  27324. /*<       XXI=0. >*/
  27325.     xxi = 0.;
  27326. /*<       GOTO 22 >*/
  27327.     goto L22;
  27328. /*<    21 QM= PI* BI( I) >*/
  27329. L21:
  27330.     qm = pi * data_1.bi[*i - 1];
  27331. /*<       XXI= QM* QM >*/
  27332.     xxi = qm * qm;
  27333. /*<       XXI= QM*(1.-.5* XXI)/(1.- XXI) >*/
  27334.     xxi = qm * (1. - xxi * .5) / (1. - xxi);
  27335. /*<    22 QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ)) >*/
  27336. L22:
  27337.     qm = (omc + xxi * sd) / (sd * (aj - xxi * pm) + cd * (pm + xxi * aj));
  27338. /*<       D= CD- XXI* SD >*/
  27339.     d = cd - xxi * sd;
  27340. /*<       BX( JSNOP)=( AJ* QM*( CDH- XXI* SDH)- SDH)/ D >*/
  27341.     d__1 = aj * qm;
  27342.     segj_1.bx[jsnop - 1] = (d__1 * (cdh - xxi * sdh) - sdh) / d;
  27343. /*<       CX( JSNOP)=( CDH- AJ* QM*( SDH+ XXI* CDH))/ D >*/
  27344.     d__1 = aj * qm;
  27345.     segj_1.cx[jsnop - 1] = (cdh - d__1 * (sdh + xxi * cdh)) / d;
  27346. /*<       DO 23  IEND=1, NJUN1 >*/
  27347.     i__1 = njun1;
  27348.     for (iend = 1; iend <= i__1; ++iend) {
  27349. /*<       AX( IEND)= AX( IEND)* QM >*/
  27350.     segj_1.ax[iend - 1] *= qm;
  27351. /*<       BX( IEND)= BX( IEND)* QM >*/
  27352.     segj_1.bx[iend - 1] *= qm;
  27353. /*<    23 CX( IEND)= CX( IEND)* QM >*/
  27354. /* L23: */
  27355.     segj_1.cx[iend - 1] *= qm;
  27356.     }
  27357. /*<       GOTO 27 >*/
  27358.     goto L27;
  27359. /*<    24 BX( JSNOP)=0. >*/
  27360. L24:
  27361.     segj_1.bx[jsnop - 1] = 0.;
  27362. /*<       IF( ICAP.NE.0) GOTO 25 >*/
  27363.     if (*icap != 0) {
  27364.     goto L25;
  27365.     }
  27366. /*<       XXI=0. >*/
  27367.     xxi = 0.;
  27368. /*<       GOTO 26 >*/
  27369.     goto L26;
  27370. /*<    25 QP= PI* BI( I) >*/
  27371. L25:
  27372.     qp = pi * data_1.bi[*i - 1];
  27373. /*<       XXI= QP* QP >*/
  27374.     xxi = qp * qp;
  27375. /*<       XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
  27376.     xxi = qp * (1. - xxi * .5) / (1. - xxi);
  27377. /*<    26 CX( JSNOP)=1./( CDH- XXI* SDH) >*/
  27378. L26:
  27379.     segj_1.cx[jsnop - 1] = 1. / (cdh - xxi * sdh);
  27380. /*<    27 JSNO= JSNOP >*/
  27381. L27:
  27382.     segj_1.jsno = jsnop;
  27383. /*<       AX( JSNO)=-1. >*/
  27384.     segj_1.ax[segj_1.jsno - 1] = -1.;
  27385. /*<       RETURN >*/
  27386.     return 0;
  27387. /*<    28 WRITE( 6,29)  I >*/
  27388. L28:
  27389.     s_wsfe(&io___2079);
  27390.     do_fio(&c__1, (char *)&(*i), (ftnlen)sizeof(integer));
  27391.     e_wsfe();
  27392.  
  27393. /*<       STOP >*/
  27394.     s_stop("", 0L);
  27395. /*<    29 FORMAT(' TBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5) >*/
  27396. /*<       END >*/
  27397. } /* tbf_ */
  27398.  
  27399. /* *** */
  27400. /*     DOUBLE PRECISION 6/4/85 */
  27401.  
  27402. /*<       SUBROUTINE TEST( F1R, F2R, TR, F1I, F2I, TI, DMIN) >*/
  27403. /* Subroutine */ int test_(f1r, f2r, tr, f1i, f2i, ti, dmin_)
  27404. doublereal *f1r, *f2r, *tr, *f1i, *f2i, *ti, *dmin_;
  27405. {
  27406.     /* System generated locals */
  27407.     doublereal d__1;
  27408.  
  27409.     /* Local variables */
  27410.     static doublereal den;
  27411.  
  27412. /* *** */
  27413.  
  27414. /*     TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION */
  27415.  
  27416. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  27417. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  27418. /*<       DEN= ABS( F2R) >*/
  27419.     den = abs(*f2r);
  27420. /*<       TR= ABS( F2I) >*/
  27421.     *tr = abs(*f2i);
  27422. /*<       IF( DEN.LT. TR) DEN= TR >*/
  27423.     if (den < *tr) {
  27424.     den = *tr;
  27425.     }
  27426. /*<       IF( DEN.LT. DMIN) DEN= DMIN >*/
  27427.     if (den < *dmin_) {
  27428.     den = *dmin_;
  27429.     }
  27430. /*<       IF( DEN.LT.1.D-37) GOTO 1 >*/
  27431.     if (den < 1e-37) {
  27432.     goto L1;
  27433.     }
  27434. /*<       TR= ABS(( F1R- F2R)/ DEN) >*/
  27435.     *tr = (d__1 = (*f1r - *f2r) / den, abs(d__1));
  27436. /*<       TI= ABS(( F1I- F2I)/ DEN) >*/
  27437.     *ti = (d__1 = (*f1i - *f2i) / den, abs(d__1));
  27438. /*<       RETURN >*/
  27439.     return 0;
  27440. /*<     1 TR=0. >*/
  27441. L1:
  27442.     *tr = 0.;
  27443. /*<       TI=0. >*/
  27444.     *ti = 0.;
  27445. /*<       RETURN >*/
  27446.     return 0;
  27447. /*<       END >*/
  27448. } /* test_ */
  27449.  
  27450. /* *** */
  27451. /*     DOUBLE PRECISION 6/4/85 */
  27452.  
  27453. /*<       SUBROUTINE TRIO( J) >*/
  27454. /* Subroutine */ int trio_(j)
  27455. integer *j;
  27456. {
  27457.     /* Initialized data */
  27458.  
  27459.     static integer jmax = 30;
  27460.  
  27461.     /* Format strings */
  27462.     static char fmt_10[] = "(\002 TRIO - SEGMENT CONNENTION ERROR FOR SEGM\
  27463. ENT\002,i5)";
  27464.  
  27465.     /* Builtin functions */
  27466.     integer s_wsfe(), do_fio(), e_wsfe();
  27467.     /* Subroutine */ int s_stop();
  27468.  
  27469.     /* Local variables */
  27470.     static integer iend, jend, jcox;
  27471.     extern /* Subroutine */ int sbf_();
  27472.  
  27473.     /* Fortran I/O blocks */
  27474.     static cilist io___2085 = { 0, 6, 0, fmt_10, 0 };
  27475.  
  27476.  
  27477. /* *** */
  27478. /*     COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J */
  27479. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  27480. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  27481. /*<    >*/
  27482. /*<    >*/
  27483. /*<       DATA   JMAX/30/ >*/
  27484. /*<       JSNO=0 >*/
  27485.     segj_1.jsno = 0;
  27486. /*<       JCOX= ICON1( J) >*/
  27487.     jcox = data_1.icon1[*j - 1];
  27488. /*<       IF( JCOX.GT.10000) GOTO 7 >*/
  27489.     if (jcox > 10000) {
  27490.     goto L7;
  27491.     }
  27492. /*<       JEND=-1 >*/
  27493.     jend = -1;
  27494. /*<       IEND=-1 >*/
  27495.     iend = -1;
  27496. /*<       IF( JCOX) 1,7,2 >*/
  27497.     if (jcox < 0) {
  27498.     goto L1;
  27499.     } else if (jcox == 0) {
  27500.     goto L7;
  27501.     } else {
  27502.     goto L2;
  27503.     }
  27504. /*<     1 JCOX=- JCOX >*/
  27505. L1:
  27506.     jcox = -jcox;
  27507. /*<       GOTO 3 >*/
  27508.     goto L3;
  27509. /*<     2 JEND=- JEND >*/
  27510. L2:
  27511.     jend = -jend;
  27512. /*<     3 IF( JCOX.EQ. J) GOTO 6 >*/
  27513. L3:
  27514.     if (jcox == *j) {
  27515.     goto L6;
  27516.     }
  27517. /*<       JSNO= JSNO+1 >*/
  27518.     ++segj_1.jsno;
  27519. /*<       IF( JSNO.GE. JMAX) GOTO 9 >*/
  27520.     if (segj_1.jsno >= jmax) {
  27521.     goto L9;
  27522.     }
  27523. /*<       CALL SBF( JCOX, J, AX( JSNO), BX( JSNO), CX( JSNO)) >*/
  27524.     sbf_(&jcox, j, &segj_1.ax[segj_1.jsno - 1], &segj_1.bx[segj_1.jsno - 1], &
  27525.         segj_1.cx[segj_1.jsno - 1]);
  27526. /*<       JCO( JSNO)= JCOX >*/
  27527.     segj_1.jco[segj_1.jsno - 1] = jcox;
  27528. /*<       IF( JEND.EQ.1) GOTO 4 >*/
  27529.     if (jend == 1) {
  27530.     goto L4;
  27531.     }
  27532. /*<       JCOX= ICON1( JCOX) >*/
  27533.     jcox = data_1.icon1[jcox - 1];
  27534. /*<       GOTO 5 >*/
  27535.     goto L5;
  27536. /*<     4 JCOX= ICON2( JCOX) >*/
  27537. L4:
  27538.     jcox = data_1.icon2[jcox - 1];
  27539. /*<     5 IF( JCOX) 1,9,2 >*/
  27540. L5:
  27541.     if (jcox < 0) {
  27542.     goto L1;
  27543.     } else if (jcox == 0) {
  27544.     goto L9;
  27545.     } else {
  27546.     goto L2;
  27547.     }
  27548. /*<     6 IF( IEND.EQ.1) GOTO 8 >*/
  27549. L6:
  27550.     if (iend == 1) {
  27551.     goto L8;
  27552.     }
  27553. /*<     7 JCOX= ICON2( J) >*/
  27554. L7:
  27555.     jcox = data_1.icon2[*j - 1];
  27556. /*<       IF( JCOX.GT.10000) GOTO 8 >*/
  27557.     if (jcox > 10000) {
  27558.     goto L8;
  27559.     }
  27560. /*<       JEND=1 >*/
  27561.     jend = 1;
  27562. /*<       IEND=1 >*/
  27563.     iend = 1;
  27564. /*<       IF( JCOX) 1,8,2 >*/
  27565.     if (jcox < 0) {
  27566.     goto L1;
  27567.     } else if (jcox == 0) {
  27568.     goto L8;
  27569.     } else {
  27570.     goto L2;
  27571.     }
  27572. /*<     8 JSNO= JSNO+1 >*/
  27573. L8:
  27574.     ++segj_1.jsno;
  27575. /*<       CALL SBF( J, J, AX( JSNO), BX( JSNO), CX( JSNO)) >*/
  27576.     sbf_(j, j, &segj_1.ax[segj_1.jsno - 1], &segj_1.bx[segj_1.jsno - 1], &
  27577.         segj_1.cx[segj_1.jsno - 1]);
  27578. /*<       JCO( JSNO)= J >*/
  27579.     segj_1.jco[segj_1.jsno - 1] = *j;
  27580. /*<       RETURN >*/
  27581.     return 0;
  27582. /*<     9 WRITE( 6,10)  J >*/
  27583. L9:
  27584.     s_wsfe(&io___2085);
  27585.     do_fio(&c__1, (char *)&(*j), (ftnlen)sizeof(integer));
  27586.     e_wsfe();
  27587.  
  27588. /*<       STOP >*/
  27589.     s_stop("", 0L);
  27590. /*<    10 FORMAT(' TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT',I5) >*/
  27591. /*<       END >*/
  27592. } /* trio_ */
  27593.  
  27594. /* *** */
  27595. /*     DOUBLE PRECISION 6/4/85 */
  27596.  
  27597. /*<       SUBROUTINE UNERE( XOB, YOB, ZOB) >*/
  27598. /* Subroutine */ int unere_(xob, yob, zob)
  27599. doublereal *xob, *yob, *zob;
  27600. {
  27601.     /* Initialized data */
  27602.  
  27603.     static doublereal tpi = 6.283185308;
  27604.     static doublereal const_ = 4.771341188;
  27605.  
  27606.     /* System generated locals */
  27607.     doublereal d__1, d__2, d__3;
  27608.     doublecomplex z__1, z__2, z__3, z__4, z__5;
  27609.  
  27610.     /* Builtin functions */
  27611.     double sqrt(), sin(), cos();
  27612.     void z_sqrt(), z_div();
  27613.  
  27614.     /* Local variables */
  27615.     static doublereal t1zr, t2zr, r, xymag;
  27616.     static doublecomplex q1, q2;
  27617.     static doublereal r2;
  27618.     static doublecomplex er;
  27619.     static doublereal rt, px, py, rx, ry, zr, rz, tt1, tt2;
  27620.     static doublecomplex edp;
  27621.     static doublereal cth;
  27622.     static doublecomplex rrh, rrv;
  27623. #define t1xj ((doublereal *)&dataj_1 + 5)
  27624. #define t1yj ((doublereal *)&dataj_1 + 6)
  27625. #define t1zj ((doublereal *)&dataj_1 + 7)
  27626. #define t2xj ((doublereal *)&dataj_1 + 1)
  27627. #define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
  27628. #define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
  27629.  
  27630. /* *** */
  27631. /*     CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2 
  27632. */
  27633. /*     DIRECTIONS ON A PATCH */
  27634. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  27635. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  27636. /*<    >*/
  27637. /*<    >*/
  27638. /*<    >*/
  27639. /*<    >*/
  27640. /*     CONST=ETA/(8.*PI**2) */
  27641. /*<       DATA   TPI, CONST/6.283185308D+0,4.771341188D+0/ >*/
  27642. /*<       ZR= ZJ >*/
  27643.     zr = dataj_1.zj;
  27644. /*<       T1ZR= T1ZJ >*/
  27645.     t1zr = *t1zj;
  27646. /*<       T2ZR= T2ZJ >*/
  27647.     t2zr = *t2zj;
  27648. /*<       IF( IPGND.NE.2) GOTO 1 >*/
  27649.     if (dataj_1.ipgnd != 2) {
  27650.     goto L1;
  27651.     }
  27652. /*<       ZR=- ZR >*/
  27653.     zr = -zr;
  27654. /*<       T1ZR=- T1ZR >*/
  27655.     t1zr = -t1zr;
  27656. /*<       T2ZR=- T2ZR >*/
  27657.     t2zr = -t2zr;
  27658. /*<     1 RX= XOB- XJ >*/
  27659. L1:
  27660.     rx = *xob - dataj_1.xj;
  27661. /*<       RY= YOB- YJ >*/
  27662.     ry = *yob - dataj_1.yj;
  27663. /*<       RZ= ZOB- ZR >*/
  27664.     rz = *zob - zr;
  27665. /*<       R2= RX* RX+ RY* RY+ RZ* RZ >*/
  27666.     d__1 = rx * rx + ry * ry;
  27667.     r2 = d__1 + rz * rz;
  27668. /*<       IF( R2.GT.1.D-20) GOTO 2 >*/
  27669.     if (r2 > 1e-20) {
  27670.     goto L2;
  27671.     }
  27672. /*<       EXK=(0.,0.) >*/
  27673.     dataj_1.exk.r = 0., dataj_1.exk.i = 0.;
  27674. /*<       EYK=(0.,0.) >*/
  27675.     dataj_1.eyk.r = 0., dataj_1.eyk.i = 0.;
  27676. /*<       EZK=(0.,0.) >*/
  27677.     dataj_1.ezk.r = 0., dataj_1.ezk.i = 0.;
  27678. /*<       EXS=(0.,0.) >*/
  27679.     dataj_1.exs.r = 0., dataj_1.exs.i = 0.;
  27680. /*<       EYS=(0.,0.) >*/
  27681.     dataj_1.eys.r = 0., dataj_1.eys.i = 0.;
  27682. /*<       EZS=(0.,0.) >*/
  27683.     dataj_1.ezs.r = 0., dataj_1.ezs.i = 0.;
  27684. /*<       RETURN >*/
  27685.     return 0;
  27686. /*<     2 R= SQRT( R2) >*/
  27687. L2:
  27688.     r = sqrt(r2);
  27689. /*<       TT1=- TPI* R >*/
  27690.     tt1 = -tpi * r;
  27691. /*<       TT2= TT1* TT1 >*/
  27692.     tt2 = tt1 * tt1;
  27693. /*<       RT= R2* R >*/
  27694.     rt = r2 * r;
  27695. /*<       ER= CMPLX( SIN( TT1),- COS( TT1))*( CONST* S) >*/
  27696.     d__1 = sin(tt1);
  27697.     d__2 = -cos(tt1);
  27698.     z__2.r = d__1, z__2.i = d__2;
  27699.     d__3 = const_ * dataj_1.s;
  27700.     z__1.r = d__3 * z__2.r, z__1.i = d__3 * z__2.i;
  27701.     er.r = z__1.r, er.i = z__1.i;
  27702. /*<       Q1= CMPLX( TT2-1., TT1)* ER/ RT >*/
  27703.     d__1 = tt2 - 1.;
  27704.     z__3.r = d__1, z__3.i = tt1;
  27705.     z__2.r = z__3.r * er.r - z__3.i * er.i, z__2.i = z__3.r * er.i + z__3.i * 
  27706.         er.r;
  27707.     z__1.r = z__2.r / rt, z__1.i = z__2.i / rt;
  27708.     q1.r = z__1.r, q1.i = z__1.i;
  27709. /*<       Q2= CMPLX(3.- TT2,-3.* TT1)* ER/( RT* R2) >*/
  27710.     d__1 = 3. - tt2;
  27711.     d__2 = tt1 * -3.;
  27712.     z__3.r = d__1, z__3.i = d__2;
  27713.     z__2.r = z__3.r * er.r - z__3.i * er.i, z__2.i = z__3.r * er.i + z__3.i * 
  27714.         er.r;
  27715.     d__3 = rt * r2;
  27716.     z__1.r = z__2.r / d__3, z__1.i = z__2.i / d__3;
  27717.     q2.r = z__1.r, q2.i = z__1.i;
  27718. /*<       ER= Q2*( T1XJ* RX+ T1YJ* RY+ T1ZR* RZ) >*/
  27719.     d__2 = *t1xj * rx + *t1yj * ry;
  27720.     d__1 = d__2 + t1zr * rz;
  27721.     z__1.r = d__1 * q2.r, z__1.i = d__1 * q2.i;
  27722.     er.r = z__1.r, er.i = z__1.i;
  27723. /*<       EXK= Q1* T1XJ+ ER* RX >*/
  27724.     z__2.r = *t1xj * q1.r, z__2.i = *t1xj * q1.i;
  27725.     z__3.r = rx * er.r, z__3.i = rx * er.i;
  27726.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27727.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  27728. /*<       EYK= Q1* T1YJ+ ER* RY >*/
  27729.     z__2.r = *t1yj * q1.r, z__2.i = *t1yj * q1.i;
  27730.     z__3.r = ry * er.r, z__3.i = ry * er.i;
  27731.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27732.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  27733. /*<       EZK= Q1* T1ZR+ ER* RZ >*/
  27734.     z__2.r = t1zr * q1.r, z__2.i = t1zr * q1.i;
  27735.     z__3.r = rz * er.r, z__3.i = rz * er.i;
  27736.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27737.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  27738. /*<       ER= Q2*( T2XJ* RX+ T2YJ* RY+ T2ZR* RZ) >*/
  27739.     d__2 = *t2xj * rx + *t2yj * ry;
  27740.     d__1 = d__2 + t2zr * rz;
  27741.     z__1.r = d__1 * q2.r, z__1.i = d__1 * q2.i;
  27742.     er.r = z__1.r, er.i = z__1.i;
  27743. /*<       EXS= Q1* T2XJ+ ER* RX >*/
  27744.     z__2.r = *t2xj * q1.r, z__2.i = *t2xj * q1.i;
  27745.     z__3.r = rx * er.r, z__3.i = rx * er.i;
  27746.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27747.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  27748. /*<       EYS= Q1* T2YJ+ ER* RY >*/
  27749.     z__2.r = *t2yj * q1.r, z__2.i = *t2yj * q1.i;
  27750.     z__3.r = ry * er.r, z__3.i = ry * er.i;
  27751.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27752.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  27753. /*<       EZS= Q1* T2ZR+ ER* RZ >*/
  27754.     z__2.r = t2zr * q1.r, z__2.i = t2zr * q1.i;
  27755.     z__3.r = rz * er.r, z__3.i = rz * er.i;
  27756.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27757.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  27758. /*<       IF( IPGND.EQ.1) GOTO 6 >*/
  27759.     if (dataj_1.ipgnd == 1) {
  27760.     goto L6;
  27761.     }
  27762. /*<       IF( IPERF.NE.1) GOTO 3 >*/
  27763.     if (gnd_1.iperf != 1) {
  27764.     goto L3;
  27765.     }
  27766. /*<       EXK=- EXK >*/
  27767.     z__1.r = -dataj_1.exk.r, z__1.i = -dataj_1.exk.i;
  27768.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  27769. /*<       EYK=- EYK >*/
  27770.     z__1.r = -dataj_1.eyk.r, z__1.i = -dataj_1.eyk.i;
  27771.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  27772. /*<       EZK=- EZK >*/
  27773.     z__1.r = -dataj_1.ezk.r, z__1.i = -dataj_1.ezk.i;
  27774.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  27775. /*<       EXS=- EXS >*/
  27776.     z__1.r = -dataj_1.exs.r, z__1.i = -dataj_1.exs.i;
  27777.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  27778. /*<       EYS=- EYS >*/
  27779.     z__1.r = -dataj_1.eys.r, z__1.i = -dataj_1.eys.i;
  27780.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  27781. /*<       EZS=- EZS >*/
  27782.     z__1.r = -dataj_1.ezs.r, z__1.i = -dataj_1.ezs.i;
  27783.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  27784. /*<       GOTO 6 >*/
  27785.     goto L6;
  27786. /*<     3 XYMAG= SQRT( RX* RX+ RY* RY) >*/
  27787. L3:
  27788.     xymag = sqrt(rx * rx + ry * ry);
  27789. /*<       IF( XYMAG.GT.1.D-6) GOTO 4 >*/
  27790.     if (xymag > 1e-6) {
  27791.     goto L4;
  27792.     }
  27793. /*<       PX=0. >*/
  27794.     px = 0.;
  27795. /*<       PY=0. >*/
  27796.     py = 0.;
  27797. /*<       CTH=1. >*/
  27798.     cth = 1.;
  27799. /*<       RRV=(1.,0.) >*/
  27800.     rrv.r = 1., rrv.i = 0.;
  27801. /*<       GOTO 5 >*/
  27802.     goto L5;
  27803. /*<     4 PX=- RY/ XYMAG >*/
  27804. L4:
  27805.     px = -ry / xymag;
  27806. /*<       PY= RX/ XYMAG >*/
  27807.     py = rx / xymag;
  27808. /*<       CTH= RZ/ SQRT( XYMAG* XYMAG+ RZ* RZ) >*/
  27809.     cth = rz / sqrt(xymag * xymag + rz * rz);
  27810. /*<       RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH)) >*/
  27811.     z__4.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i * gnd_1.zrati.i, 
  27812.         z__4.i = gnd_1.zrati.r * gnd_1.zrati.i + gnd_1.zrati.i * 
  27813.         gnd_1.zrati.r;
  27814.     d__1 = 1. - cth * cth;
  27815.     z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
  27816.     z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
  27817.     z_sqrt(&z__1, &z__2);
  27818.     rrv.r = z__1.r, rrv.i = z__1.i;
  27819. /*<     5 RRH= ZRATI* CTH >*/
  27820. L5:
  27821.     z__1.r = cth * gnd_1.zrati.r, z__1.i = cth * gnd_1.zrati.i;
  27822.     rrh.r = z__1.r, rrh.i = z__1.i;
  27823. /*<       RRH=( RRH- RRV)/( RRH+ RRV) >*/
  27824.     z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
  27825.     z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
  27826.     z_div(&z__1, &z__2, &z__3);
  27827.     rrh.r = z__1.r, rrh.i = z__1.i;
  27828. /*<       RRV= ZRATI* RRV >*/
  27829.     z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i = 
  27830.         gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
  27831.     rrv.r = z__1.r, rrv.i = z__1.i;
  27832. /*<       RRV=-( CTH- RRV)/( CTH+ RRV) >*/
  27833.     z__3.r = cth - rrv.r, z__3.i = -rrv.i;
  27834.     z__2.r = -z__3.r, z__2.i = -z__3.i;
  27835.     z__4.r = cth + rrv.r, z__4.i = rrv.i;
  27836.     z_div(&z__1, &z__2, &z__4);
  27837.     rrv.r = z__1.r, rrv.i = z__1.i;
  27838. /*<       EDP=( EXK* PX+ EYK* PY)*( RRH- RRV) >*/
  27839.     z__3.r = px * dataj_1.exk.r, z__3.i = px * dataj_1.exk.i;
  27840.     z__4.r = py * dataj_1.eyk.r, z__4.i = py * dataj_1.eyk.i;
  27841.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  27842.     z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
  27843.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i + 
  27844.         z__2.i * z__5.r;
  27845.     edp.r = z__1.r, edp.i = z__1.i;
  27846. /*<       EXK= EXK* RRV+ EDP* PX >*/
  27847.     z__2.r = dataj_1.exk.r * rrv.r - dataj_1.exk.i * rrv.i, z__2.i = 
  27848.         dataj_1.exk.r * rrv.i + dataj_1.exk.i * rrv.r;
  27849.     z__3.r = px * edp.r, z__3.i = px * edp.i;
  27850.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27851.     dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
  27852. /*<       EYK= EYK* RRV+ EDP* PY >*/
  27853.     z__2.r = dataj_1.eyk.r * rrv.r - dataj_1.eyk.i * rrv.i, z__2.i = 
  27854.         dataj_1.eyk.r * rrv.i + dataj_1.eyk.i * rrv.r;
  27855.     z__3.r = py * edp.r, z__3.i = py * edp.i;
  27856.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27857.     dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
  27858. /*<       EZK= EZK* RRV >*/
  27859.     z__1.r = dataj_1.ezk.r * rrv.r - dataj_1.ezk.i * rrv.i, z__1.i = 
  27860.         dataj_1.ezk.r * rrv.i + dataj_1.ezk.i * rrv.r;
  27861.     dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
  27862. /*<       EDP=( EXS* PX+ EYS* PY)*( RRH- RRV) >*/
  27863.     z__3.r = px * dataj_1.exs.r, z__3.i = px * dataj_1.exs.i;
  27864.     z__4.r = py * dataj_1.eys.r, z__4.i = py * dataj_1.eys.i;
  27865.     z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
  27866.     z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
  27867.     z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i + 
  27868.         z__2.i * z__5.r;
  27869.     edp.r = z__1.r, edp.i = z__1.i;
  27870. /*<       EXS= EXS* RRV+ EDP* PX >*/
  27871.     z__2.r = dataj_1.exs.r * rrv.r - dataj_1.exs.i * rrv.i, z__2.i = 
  27872.         dataj_1.exs.r * rrv.i + dataj_1.exs.i * rrv.r;
  27873.     z__3.r = px * edp.r, z__3.i = px * edp.i;
  27874.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27875.     dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
  27876. /*<       EYS= EYS* RRV+ EDP* PY >*/
  27877.     z__2.r = dataj_1.eys.r * rrv.r - dataj_1.eys.i * rrv.i, z__2.i = 
  27878.         dataj_1.eys.r * rrv.i + dataj_1.eys.i * rrv.r;
  27879.     z__3.r = py * edp.r, z__3.i = py * edp.i;
  27880.     z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
  27881.     dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
  27882. /*<       EZS= EZS* RRV >*/
  27883.     z__1.r = dataj_1.ezs.r * rrv.r - dataj_1.ezs.i * rrv.i, z__1.i = 
  27884.         dataj_1.ezs.r * rrv.i + dataj_1.ezs.i * rrv.r;
  27885.     dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
  27886. /*<     6 RETURN >*/
  27887. L6:
  27888.     return 0;
  27889. /*<       END >*/
  27890. } /* unere_ */
  27891.  
  27892. #undef t2zj
  27893. #undef t2yj
  27894. #undef t2xj
  27895. #undef t1zj
  27896. #undef t1yj
  27897. #undef t1xj
  27898.  
  27899.  
  27900. /* *** */
  27901. /*     DOUBLE PRECISION 6/4/85 */
  27902.  
  27903. /*<    >*/
  27904. /* Subroutine */ int wire_(xw1, yw1, zw1, xw2, yw2, zw2, rad, rdel, rrad, ns, 
  27905.     itg)
  27906. doublereal *xw1, *yw1, *zw1, *xw2, *yw2, *zw2, *rad, *rdel, *rrad;
  27907. integer *ns, *itg;
  27908. {
  27909.     /* System generated locals */
  27910.     integer i__1;
  27911.     doublereal d__1;
  27912.  
  27913.     /* Builtin functions */
  27914.     double sqrt(), pow_di();
  27915.  
  27916.     /* Local variables */
  27917.     static doublereal delz, radz;
  27918.     static integer i;
  27919. #define x2 ((doublereal *)&data_1 + 1800)
  27920. #define y2 ((doublereal *)&data_1 + 3000)
  27921. #define z2 ((doublereal *)&data_1 + 3600)
  27922.     static doublereal rd, xd, yd, zd, xs1, ys1, zs1, xs2, ys2, zs2, fns;
  27923.     static integer ist;
  27924.  
  27925. /* *** */
  27926.  
  27927. /*     SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT */
  27928. /*     WIRE OF NS SEGMENTS. */
  27929.  
  27930. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  27931. /*<       PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
  27932. /*<    >*/
  27933. /*<       DIMENSION  X2(1), Y2(1), Z2(1) >*/
  27934. /*<       EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1)) >*/
  27935. /*<       IST= N+1 >*/
  27936.     ist = data_1.n + 1;
  27937. /*<       N= N+ NS >*/
  27938.     data_1.n += *ns;
  27939. /*<       NP= N >*/
  27940.     data_1.np = data_1.n;
  27941. /*<       MP= M >*/
  27942.     data_1.mp = data_1.m;
  27943. /*<       IPSYM=0 >*/
  27944.     data_1.ipsym = 0;
  27945. /*<       IF( NS.LT.1) RETURN >*/
  27946.     if (*ns < 1) {
  27947.     return 0;
  27948.     }
  27949. /*<       XD= XW2- XW1 >*/
  27950.     xd = *xw2 - *xw1;
  27951. /*<       YD= YW2- YW1 >*/
  27952.     yd = *yw2 - *yw1;
  27953. /*<       ZD= ZW2- ZW1 >*/
  27954.     zd = *zw2 - *zw1;
  27955. /*<       IF( ABS( RDEL-1.).LT.1.D-6) GOTO 1 >*/
  27956.     if ((d__1 = *rdel - 1., abs(d__1)) < 1e-6) {
  27957.     goto L1;
  27958.     }
  27959. /*<       DELZ= SQRT( XD* XD+ YD* YD+ ZD* ZD) >*/
  27960.     d__1 = xd * xd + yd * yd;
  27961.     delz = sqrt(d__1 + zd * zd);
  27962. /*<       XD= XD/ DELZ >*/
  27963.     xd /= delz;
  27964. /*<       YD= YD/ DELZ >*/
  27965.     yd /= delz;
  27966. /*<       ZD= ZD/ DELZ >*/
  27967.     zd /= delz;
  27968. /*<       DELZ= DELZ*(1.- RDEL)/(1.- RDEL** NS) >*/
  27969.     delz = delz * (1. - *rdel) / (1. - pow_di(rdel, ns));
  27970. /*<       RD= RDEL >*/
  27971.     rd = *rdel;
  27972. /*<       GOTO 2 >*/
  27973.     goto L2;
  27974. /*<     1 FNS= NS >*/
  27975. L1:
  27976.     fns = (doublereal) (*ns);
  27977. /*<       XD= XD/ FNS >*/
  27978.     xd /= fns;
  27979. /*<       YD= YD/ FNS >*/
  27980.     yd /= fns;
  27981. /*<       ZD= ZD/ FNS >*/
  27982.     zd /= fns;
  27983. /*<       DELZ=1. >*/
  27984.     delz = 1.;
  27985. /*<       RD=1. >*/
  27986.     rd = 1.;
  27987. /*<     2 RADZ= RAD >*/
  27988. L2:
  27989.     radz = *rad;
  27990. /*<       XS1= XW1 >*/
  27991.     xs1 = *xw1;
  27992. /*<       YS1= YW1 >*/
  27993.     ys1 = *yw1;
  27994. /*<       ZS1= ZW1 >*/
  27995.     zs1 = *zw1;
  27996. /*<       DO 3  I= IST, N >*/
  27997.     i__1 = data_1.n;
  27998.     for (i = ist; i <= i__1; ++i) {
  27999. /*<       ITAG( I)= ITG >*/
  28000.     data_1.itag[i - 1] = *itg;
  28001. /*<       XS2= XS1+ XD* DELZ >*/
  28002.     xs2 = xs1 + xd * delz;
  28003. /*<       YS2= YS1+ YD* DELZ >*/
  28004.     ys2 = ys1 + yd * delz;
  28005. /*<       ZS2= ZS1+ ZD* DELZ >*/
  28006.     zs2 = zs1 + zd * delz;
  28007. /*<       X( I)= XS1 >*/
  28008.     data_1.x[i - 1] = xs1;
  28009. /*<       Y( I)= YS1 >*/
  28010.     data_1.y[i - 1] = ys1;
  28011. /*<       Z( I)= ZS1 >*/
  28012.     data_1.z[i - 1] = zs1;
  28013. /*<       X2( I)= XS2 >*/
  28014.     x2[i - 1] = xs2;
  28015. /*<       Y2( I)= YS2 >*/
  28016.     y2[i - 1] = ys2;
  28017. /*<       Z2( I)= ZS2 >*/
  28018.     z2[i - 1] = zs2;
  28019. /*<       BI( I)= RADZ >*/
  28020.     data_1.bi[i - 1] = radz;
  28021. /*<       DELZ= DELZ* RD >*/
  28022.     delz *= rd;
  28023. /*<       RADZ= RADZ* RRAD >*/
  28024.     radz *= *rrad;
  28025. /*<       XS1= XS2 >*/
  28026.     xs1 = xs2;
  28027. /*<       YS1= YS2 >*/
  28028.     ys1 = ys2;
  28029. /*<     3 ZS1= ZS2 >*/
  28030. /* L3: */
  28031.     zs1 = zs2;
  28032.     }
  28033. /*<       X2( N)= XW2 >*/
  28034.     x2[data_1.n - 1] = *xw2;
  28035. /*<       Y2( N)= YW2 >*/
  28036.     y2[data_1.n - 1] = *yw2;
  28037. /*<       Z2( N)= ZW2 >*/
  28038.     z2[data_1.n - 1] = *zw2;
  28039. /*<       RETURN >*/
  28040.     return 0;
  28041. /*<       END >*/
  28042. } /* wire_ */
  28043.  
  28044. #undef z2
  28045. #undef y2
  28046. #undef x2
  28047.  
  28048.  
  28049. /* *** */
  28050. /*     DOUBLE PRECISION 6/4/85 */
  28051.  
  28052. /*<       FUNCTION ZINT( SIGL, ROLAM) >*/
  28053. /* Double Complex */ int zint_( ret_val, sigl, rolam)
  28054. doublecomplex * ret_val;
  28055. doublereal *sigl, *rolam;
  28056. {
  28057.     /* Initialized data */
  28058.  
  28059.     static doublereal pi = 3.1415926;
  28060.     static doublereal pot = 1.5707963;
  28061.     static doublereal tp = 6.2831853;
  28062.     static doublereal tpcmu = 2368.705;
  28063.     static doublereal cmotp = 60.;
  28064.     static struct {
  28065.     doublereal e_1[3];
  28066.     } equiv_0 = { 0., 1., 0. };
  28067.  
  28068.     static struct {
  28069.     doublereal e_1[3];
  28070.     } equiv_1 = { .70710678, .70710678, 0. };
  28071.  
  28072.     static struct {
  28073.     doublereal e_1[29];
  28074.     } equiv_15 = { 6e-7, 1.9e-6, -3.4e-6, 5.1e-6, -2.52e-5, 0., -9.06e-5, 
  28075.         -9.01e-5, 0., -9.765e-4, .0110486, -.0110485, 0., -.3926991, 
  28076.         1.6e-6, -3.2e-6, 1.17e-5, -2.4e-6, 3.46e-5, 3.38e-5, 5e-7, 
  28077.         2.452e-4, -.0013813, .0013811, -.0625001, -1e-7, .7071068, 
  28078.         .7071068, 0. };
  28079.  
  28080.  
  28081.     /* System generated locals */
  28082.     doublereal d__1, d__2, d__3, d__4;
  28083.     doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
  28084.          z__11, z__12, z__13, z__14, z__15, z__16, z__17, z__18, z__19, 
  28085.         z__20, z__21, z__22, z__23, z__24, z__25, z__26, z__27, z__28, 
  28086.         z__29, z__30, z__31, z__32, z__33, z__34, z__35, z__36, z__37, 
  28087.         z__38, z__39, z__40, z__41, z__42, z__43;
  28088.  
  28089.     /* Builtin functions */
  28090.     double sqrt();
  28091.     void z_div(), z_exp();
  28092.  
  28093.     /* Local variables */
  28094.     static doublereal s, x, y;
  28095. #define fj ((doublecomplex *)&equiv_0)
  28096. #define cn ((doublecomplex *)&equiv_1)
  28097. #define cc1 ((doublecomplex *)&equiv_15)
  28098. #define cc2 ((doublecomplex *)&equiv_15 + 1)
  28099. #define cc3 ((doublecomplex *)&equiv_15 + 2)
  28100. #define cc4 ((doublecomplex *)&equiv_15 + 3)
  28101. #define cc5 ((doublecomplex *)&equiv_15 + 4)
  28102. #define cc6 ((doublecomplex *)&equiv_15 + 5)
  28103. #define cc7 ((doublecomplex *)&equiv_15 + 6)
  28104. #define cc8 ((doublecomplex *)&equiv_15 + 7)
  28105. #define cc9 ((doublecomplex *)&equiv_15 + 8)
  28106.     static doublecomplex br1, br2;
  28107. #define cc10 ((doublecomplex *)&equiv_15 + 9)
  28108. #define cc11 ((doublecomplex *)&equiv_15 + 10)
  28109. #define cc12 ((doublecomplex *)&equiv_15 + 11)
  28110. #define cc13 ((doublecomplex *)&equiv_15 + 12)
  28111. #define cc14 ((doublecomplex *)&equiv_15 + 13)
  28112.     static doublereal bei;
  28113. #define ccn ((doublereal *)&equiv_15)
  28114.     static doublereal ber;
  28115. #define fjx ((doublereal *)&equiv_0)
  28116. #define cnx ((doublereal *)&equiv_1)
  28117.  
  28118. /* *** */
  28119.  
  28120. /*     ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE */
  28121.  
  28122.  
  28123. /*<       IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
  28124. /*<       COMPLEX  TH, PH, F, G, FJ, CN, BR1, BR2, ZINT >*/
  28125. /*<    >*/
  28126. /*<       DIMENSION  FJX(2), CNX(2), CCN(28) >*/
  28127. /*<    >*/
  28128. /*<    >*/
  28129. /*<       DATA   CMOTP/60.00/, FJX/0.,1./, CNX/.70710678D+0,.70710678D+0/ >*/
  28130. /*<    >*/
  28131. /*<    >*/
  28132. /*<    >*/
  28133. /*<       F( D)= SQRT( POT/ D)* EXP(- CN* D+ TH(-8./ X)) >*/
  28134. /*<       G( D)= EXP( CN* D+ TH(8./ X))/ SQRT( TP* D) >*/
  28135. /*<       X= SQRT( TPCMU* SIGL)* ROLAM >*/
  28136.     x = sqrt(tpcmu * *sigl) * *rolam;
  28137. /*<       IF( X.GT.110.) GOTO 2 >*/
  28138.     if (x > 110.) {
  28139.     goto L2;
  28140.     }
  28141. /*<       IF( X.GT.8.) GOTO 1 >*/
  28142.     if (x > 8.) {
  28143.     goto L1;
  28144.     }
  28145. /*<       Y= X/8. >*/
  28146.     y = x / 8.;
  28147. /*<       Y= Y* Y >*/
  28148.     y *= y;
  28149. /*<       S= Y* Y >*/
  28150.     s = y * y;
  28151. /*<    >*/
  28152.     ber = ((((((s * -9.01e-6 + .00122552) * s - .08349609) * s + 2.641914) * 
  28153.         s - 32.363456) * s + 113.77778) * s - 64.) * s + 1.;
  28154. /*<    >*/
  28155.     bei = ((((((s * 1.1346e-4 - .01103667) * s + .52185615) * s - 10.567658) *
  28156.          s + 72.817777) * s - 113.77778) * s + 16.) * y;
  28157. /*<       BR1= CMPLX( BER, BEI) >*/
  28158.     z__1.r = ber, z__1.i = bei;
  28159.     br1.r = z__1.r, br1.i = z__1.i;
  28160. /*<    >*/
  28161.     d__1 = ((((((s * -3.94e-6 + 4.5957e-4) * s - .02609253) * s + .66047849) *
  28162.          s - 6.0681481) * s + 14.222222) * s - 4.) * y;
  28163.     ber = d__1 * x;
  28164. /*<    >*/
  28165.     bei = ((((((s * 4.609e-5 - .00379386) * s + .14677204) * s - 2.3116751) * 
  28166.         s + 11.377778) * s - 10.666667) * s + .5) * x;
  28167. /*<       BR2= CMPLX( BER, BEI) >*/
  28168.     z__1.r = ber, z__1.i = bei;
  28169.     br2.r = z__1.r, br2.i = z__1.i;
  28170. /*<       BR1= BR1/ BR2 >*/
  28171.     z_div(&z__1, &br1, &br2);
  28172.     br1.r = z__1.r, br1.i = z__1.i;
  28173. /*<       GOTO 3 >*/
  28174.     goto L3;
  28175. /*<     1 BR2= FJ* F( X)/ PI >*/
  28176. L1:
  28177.     d__1 = -8. / x;
  28178.     d__2 = sqrt(pot / x);
  28179.     z__7.r = -cn->r, z__7.i = -cn->i;
  28180.     z__6.r = x * z__7.r, z__6.i = x * z__7.i;
  28181.     z__19.r = d__1 * cc1->r, z__19.i = d__1 * cc1->i;
  28182.     z__18.r = z__19.r + cc2->r, z__18.i = z__19.i + cc2->i;
  28183.     z__17.r = d__1 * z__18.r, z__17.i = d__1 * z__18.i;
  28184.     z__16.r = z__17.r + cc3->r, z__16.i = z__17.i + cc3->i;
  28185.     z__15.r = d__1 * z__16.r, z__15.i = d__1 * z__16.i;
  28186.     z__14.r = z__15.r + cc4->r, z__14.i = z__15.i + cc4->i;
  28187.     z__13.r = d__1 * z__14.r, z__13.i = d__1 * z__14.i;
  28188.     z__12.r = z__13.r + cc5->r, z__12.i = z__13.i + cc5->i;
  28189.     z__11.r = d__1 * z__12.r, z__11.i = d__1 * z__12.i;
  28190.     z__10.r = z__11.r + cc6->r, z__10.i = z__11.i + cc6->i;
  28191.     z__9.r = d__1 * z__10.r, z__9.i = d__1 * z__10.i;
  28192.     z__8.r = z__9.r + cc7->r, z__8.i = z__9.i + cc7->i;
  28193.     z__5.r = z__6.r + z__8.r, z__5.i = z__6.i + z__8.i;
  28194.     z_exp(&z__4, &z__5);
  28195.     z__3.r = d__2 * z__4.r, z__3.i = d__2 * z__4.i;
  28196.     z__2.r = fj->r * z__3.r - fj->i * z__3.i, z__2.i = fj->r * z__3.i + fj->i 
  28197.         * z__3.r;
  28198.     z__1.r = z__2.r / pi, z__1.i = z__2.i / pi;
  28199.     br2.r = z__1.r, br2.i = z__1.i;
  28200. /*<       BR1= G( X)+ BR2 >*/
  28201.     d__1 = 8. / x;
  28202.     z__5.r = x * cn->r, z__5.i = x * cn->i;
  28203.     z__17.r = d__1 * cc1->r, z__17.i = d__1 * cc1->i;
  28204.     z__16.r = z__17.r + cc2->r, z__16.i = z__17.i + cc2->i;
  28205.     z__15.r = d__1 * z__16.r, z__15.i = d__1 * z__16.i;
  28206.     z__14.r = z__15.r + cc3->r, z__14.i = z__15.i + cc3->i;
  28207.     z__13.r = d__1 * z__14.r, z__13.i = d__1 * z__14.i;
  28208.     z__12.r = z__13.r + cc4->r, z__12.i = z__13.i + cc4->i;
  28209.     z__11.r = d__1 * z__12.r, z__11.i = d__1 * z__12.i;
  28210.     z__10.r = z__11.r + cc5->r, z__10.i = z__11.i + cc5->i;
  28211.     z__9.r = d__1 * z__10.r, z__9.i = d__1 * z__10.i;
  28212.     z__8.r = z__9.r + cc6->r, z__8.i = z__9.i + cc6->i;
  28213.     z__7.r = d__1 * z__8.r, z__7.i = d__1 * z__8.i;
  28214.     z__6.r = z__7.r + cc7->r, z__6.i = z__7.i + cc7->i;
  28215.     z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
  28216.     z_exp(&z__3, &z__4);
  28217.     d__2 = sqrt(tp * x);
  28218.     z__2.r = z__3.r / d__2, z__2.i = z__3.i / d__2;
  28219.     z__1.r = z__2.r + br2.r, z__1.i = z__2.i + br2.i;
  28220.     br1.r = z__1.r, br1.i = z__1.i;
  28221. /*<       BR2= G( X)* PH(8./ X)- BR2* PH(-8./ X) >*/
  28222.     d__1 = 8. / x;
  28223.     d__2 = 8. / x;
  28224.     d__3 = -8. / x;
  28225.     z__6.r = x * cn->r, z__6.i = x * cn->i;
  28226.     z__18.r = d__1 * cc1->r, z__18.i = d__1 * cc1->i;
  28227.     z__17.r = z__18.r + cc2->r, z__17.i = z__18.i + cc2->i;
  28228.     z__16.r = d__1 * z__17.r, z__16.i = d__1 * z__17.i;
  28229.     z__15.r = z__16.r + cc3->r, z__15.i = z__16.i + cc3->i;
  28230.     z__14.r = d__1 * z__15.r, z__14.i = d__1 * z__15.i;
  28231.     z__13.r = z__14.r + cc4->r, z__13.i = z__14.i + cc4->i;
  28232.     z__12.r = d__1 * z__13.r, z__12.i = d__1 * z__13.i;
  28233.     z__11.r = z__12.r + cc5->r, z__11.i = z__12.i + cc5->i;
  28234.     z__10.r = d__1 * z__11.r, z__10.i = d__1 * z__11.i;
  28235.     z__9.r = z__10.r + cc6->r, z__9.i = z__10.i + cc6->i;
  28236.     z__8.r = d__1 * z__9.r, z__8.i = d__1 * z__9.i;
  28237.     z__7.r = z__8.r + cc7->r, z__7.i = z__8.i + cc7->i;
  28238.     z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
  28239.     z_exp(&z__4, &z__5);
  28240.     d__4 = sqrt(tp * x);
  28241.     z__3.r = z__4.r / d__4, z__3.i = z__4.i / d__4;
  28242.     z__30.r = d__2 * cc8->r, z__30.i = d__2 * cc8->i;
  28243.     z__29.r = z__30.r + cc9->r, z__29.i = z__30.i + cc9->i;
  28244.     z__28.r = d__2 * z__29.r, z__28.i = d__2 * z__29.i;
  28245.     z__27.r = z__28.r + cc10->r, z__27.i = z__28.i + cc10->i;
  28246.     z__26.r = d__2 * z__27.r, z__26.i = d__2 * z__27.i;
  28247.     z__25.r = z__26.r + cc11->r, z__25.i = z__26.i + cc11->i;
  28248.     z__24.r = d__2 * z__25.r, z__24.i = d__2 * z__25.i;
  28249.     z__23.r = z__24.r + cc12->r, z__23.i = z__24.i + cc12->i;
  28250.     z__22.r = d__2 * z__23.r, z__22.i = d__2 * z__23.i;
  28251.     z__21.r = z__22.r + cc13->r, z__21.i = z__22.i + cc13->i;
  28252.     z__20.r = d__2 * z__21.r, z__20.i = d__2 * z__21.i;
  28253.     z__19.r = z__20.r + cc14->r, z__19.i = z__20.i + cc14->i;
  28254.     z__2.r = z__3.r * z__19.r - z__3.i * z__19.i, z__2.i = z__3.r * z__19.i + 
  28255.         z__3.i * z__19.r;
  28256.     z__43.r = d__3 * cc8->r, z__43.i = d__3 * cc8->i;
  28257.     z__42.r = z__43.r + cc9->r, z__42.i = z__43.i + cc9->i;
  28258.     z__41.r = d__3 * z__42.r, z__41.i = d__3 * z__42.i;
  28259.     z__40.r = z__41.r + cc10->r, z__40.i = z__41.i + cc10->i;
  28260.     z__39.r = d__3 * z__40.r, z__39.i = d__3 * z__40.i;
  28261.     z__38.r = z__39.r + cc11->r, z__38.i = z__39.i + cc11->i;
  28262.     z__37.r = d__3 * z__38.r, z__37.i = d__3 * z__38.i;
  28263.     z__36.r = z__37.r + cc12->r, z__36.i = z__37.i + cc12->i;
  28264.     z__35.r = d__3 * z__36.r, z__35.i = d__3 * z__36.i;
  28265.     z__34.r = z__35.r + cc13->r, z__34.i = z__35.i + cc13->i;
  28266.     z__33.r = d__3 * z__34.r, z__33.i = d__3 * z__34.i;
  28267.     z__32.r = z__33.r + cc14->r, z__32.i = z__33.i + cc14->i;
  28268.     z__31.r = br2.r * z__32.r - br2.i * z__32.i, z__31.i = br2.r * z__32.i + 
  28269.         br2.i * z__32.r;
  28270.     z__1.r = z__2.r - z__31.r, z__1.i = z__2.i - z__31.i;
  28271.     br2.r = z__1.r, br2.i = z__1.i;
  28272. /*<       BR1= BR1/ BR2 >*/
  28273.     z_div(&z__1, &br1, &br2);
  28274.     br1.r = z__1.r, br1.i = z__1.i;
  28275. /*<       GOTO 3 >*/
  28276.     goto L3;
  28277. /*<     2 BR1= CMPLX(.70710678D+0,-.70710678D+0) >*/
  28278. L2:
  28279.     br1.r = .70710678, br1.i = -.70710678;
  28280. /*<     3 ZINT= FJ* SQRT( CMOTP/ SIGL)* BR1/ ROLAM >*/
  28281. L3:
  28282.     d__1 = sqrt(cmotp / *sigl);
  28283.     z__3.r = d__1 * fj->r, z__3.i = d__1 * fj->i;
  28284.     z__2.r = z__3.r * br1.r - z__3.i * br1.i, z__2.i = z__3.r * br1.i + 
  28285.         z__3.i * br1.r;
  28286.     z__1.r = z__2.r / *rolam, z__1.i = z__2.i / *rolam;
  28287.      ret_val->r = z__1.r,  ret_val->i = z__1.i;
  28288. /*<       RETURN >*/
  28289.     return ;
  28290. /*<       END >*/
  28291. } /* zint_ */
  28292.  
  28293. #undef cnx
  28294. #undef fjx
  28295. #undef ccn
  28296. #undef cc14
  28297. #undef cc13
  28298. #undef cc12
  28299. #undef cc11
  28300. #undef cc10
  28301. #undef cc9
  28302. #undef cc8
  28303. #undef cc7
  28304. #undef cc6
  28305. #undef cc5
  28306. #undef cc4
  28307. #undef cc3
  28308. #undef cc2
  28309. #undef cc1
  28310. #undef cn
  28311. #undef fj
  28312.  
  28313.  
  28314. /*<       SUBROUTINE STR0PC( STRING, STRING1) >*/
  28315. /* Subroutine */ int str0pc_(string, string1, string_len, string1_len)
  28316. char *string, *string1;
  28317. ftnlen string_len;
  28318. ftnlen string1_len;
  28319. {
  28320.     /* System generated locals */
  28321.     integer i__1;
  28322.  
  28323.     /* Builtin functions */
  28324.     integer i_len();
  28325.  
  28326.     /* Local variables */
  28327.     static integer i, ic;
  28328.  
  28329. /*<       CHARACTER *(*)  STRING, STRING1 >*/
  28330. /*<       INTEGER*4  I, J, IC >*/
  28331. /*<       DO 150, I=1, LEN( STRING) >*/
  28332.     i__1 = i_len(string, string_len);
  28333.     for (i = 1; i <= i__1; ++i) {
  28334. /*<       IC= ICHAR( STRING( I: I)) >*/
  28335.     ic = string[i - 1];
  28336. /*<       IF( IC.GE.97.AND. IC.LE.122) IC= IC-32 >*/
  28337.     if (ic >= 97 && ic <= 122) {
  28338.         ic += -32;
  28339.     }
  28340. /*<       STRING1( I: I)= CHAR( IC) >*/
  28341.     string1[i - 1] = ic;
  28342. /*<   150 CONTINUE >*/
  28343. /* L150: */
  28344.     }
  28345. /*<       RETURN >*/
  28346.     return 0;
  28347. /*<       END >*/
  28348. } /* str0pc_ */
  28349.  
  28350.